refactor(services): move services to repository
This commit is contained in:
Mahdi Dibaiee
parent
cf6670bafa
commit
7c80963642
0
memory_logfile
Normal file
0
memory_logfile
Normal file
@ -38,8 +38,6 @@ library
|
||||
, directory
|
||||
, filepath
|
||||
, async
|
||||
, mysql >= 0.1.4 && < 1
|
||||
, mongoDB >= 2.1.1.1 && < 3
|
||||
, text
|
||||
, bytestring
|
||||
, unix
|
||||
|
||||
@ -21,12 +21,12 @@ module System.Serverman ( run
|
||||
|
||||
run :: Action r -> App r
|
||||
run (Pure r) = return r
|
||||
run (Free (DetectOS next)) = getOS >>= run . next
|
||||
run (Free (Start os service next)) = startService os service >> run next
|
||||
run (Free (Stop os service next)) = stopService os service >> run next
|
||||
run (Free (Install os service next)) = installService os service >> run next
|
||||
run (Free (DetectOS next)) = getOS >> run next
|
||||
run (Free (Start service next)) = startService service >> run next
|
||||
run (Free (Stop service next)) = stopService service >> run next
|
||||
run (Free (Install service next)) = installService service >> run next
|
||||
|
||||
run (Free (Call service params next)) = callService service params >> run next
|
||||
run (Free (Call service next)) = callService service >> run next
|
||||
|
||||
run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next
|
||||
|
||||
|
||||
@ -14,8 +14,8 @@ module System.Serverman.Action ( ActionF(..)
|
||||
import System.Serverman.Actions.Repository
|
||||
import System.Serverman.Actions.Remote
|
||||
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Types
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Services
|
||||
|
||||
import System.Directory
|
||||
@ -28,39 +28,39 @@ module System.Serverman.Action ( ActionF(..)
|
||||
import System.IO.Error
|
||||
import Data.Char
|
||||
|
||||
data ActionF x = Call Service Params x
|
||||
| DetectOS (OS -> x)
|
||||
| Install Service OS x
|
||||
data ActionF x = Call Service x
|
||||
| DetectOS x
|
||||
| Install Service x
|
||||
| Remote [Address] (Action ()) x
|
||||
| FetchRepository x
|
||||
| Start Service OS x
|
||||
| Stop Service OS x
|
||||
| Start Service x
|
||||
| Stop Service x
|
||||
|
||||
instance Functor ActionF where
|
||||
fmap f (Call service params x) = Call service params (f x)
|
||||
fmap f (Install service os x) = Install service os (f x)
|
||||
fmap f (Start service os x) = Start service os (f x)
|
||||
fmap f (Stop service os x) = Stop service os (f x)
|
||||
fmap f (DetectOS x) = DetectOS (f . x)
|
||||
fmap f (Call service x) = Call service (f x)
|
||||
fmap f (Install service x) = Install service (f x)
|
||||
fmap f (Start service x) = Start service (f x)
|
||||
fmap f (Stop service x) = Stop service (f x)
|
||||
fmap f (DetectOS x) = DetectOS (f x)
|
||||
fmap f (Remote addr action x) = Remote addr action (f x)
|
||||
fmap f (FetchRepository x) = FetchRepository (f x)
|
||||
|
||||
type Action = Free ActionF
|
||||
|
||||
call :: Service -> Params -> Action ()
|
||||
call service params = liftF $ Call service params ()
|
||||
call :: Service -> Action ()
|
||||
call service = liftF $ Call service ()
|
||||
|
||||
install :: Service -> OS -> Action ()
|
||||
install service os = liftF $ Install service os ()
|
||||
install :: Service -> Action ()
|
||||
install service = liftF $ Install service ()
|
||||
|
||||
start :: Service -> OS -> Action ()
|
||||
start service os = liftF $ Start service os ()
|
||||
start :: Service -> Action ()
|
||||
start service = liftF $ Start service ()
|
||||
|
||||
stop :: Service -> OS -> Action ()
|
||||
stop service os = liftF $ Stop service os ()
|
||||
stop :: Service -> Action ()
|
||||
stop service = liftF $ Stop service ()
|
||||
|
||||
detectOS :: Action OS
|
||||
detectOS = liftF $ DetectOS id
|
||||
detectOS :: Action ()
|
||||
detectOS = liftF $ DetectOS ()
|
||||
|
||||
remote :: [Address] -> Action () -> Action ()
|
||||
remote addrs action = liftF $ Remote addrs action ()
|
||||
|
||||
@ -14,51 +14,44 @@ module System.Serverman.Actions.Call (callService) where
|
||||
import Data.List
|
||||
import Stack.Package
|
||||
|
||||
callService :: Service -> Params -> App ()
|
||||
callService s@(Service { name, version }) params = do
|
||||
callService :: Service -> App ()
|
||||
callService s@(Service { name, version }) = do
|
||||
state@(AppState { repositoryURL }) <- get
|
||||
|
||||
dir <- liftIO $ getAppUserDataDirectory "serverman"
|
||||
let path = dir </> "repository" </> "services" </> name
|
||||
source = dir </> "source" </> "src"
|
||||
entry = path </> "src" </> "Main.hs"
|
||||
object = path </> "Main.o"
|
||||
src = path </> "src"
|
||||
entry = src </> "Main.hs"
|
||||
|
||||
packages <- liftIO $ readFile $ path </> "packages"
|
||||
|
||||
{-result <- exec "stack" (["ghc", entry, "--package", intercalate "," . lines $ packages, "--"] ++ includeArgs) "" (Just source) True-}
|
||||
{-let packagePaths = splitAtElem packagePath ':'-}
|
||||
let include = [source, path]
|
||||
let include = [source, src]
|
||||
includeArgs = map ("-i"++) include
|
||||
|
||||
(Right stackEnv) <- exec "stack" ["install", "--dependencies-only"] "" (Just path) True
|
||||
(Right stackEnv) <- exec "stack" ["exec", "env"] "" (Just path) True
|
||||
|
||||
backupEnv <- liftIO $ getEnvironment
|
||||
liftIO $ setEnvironment $ parseKeyValue stackEnv '='
|
||||
|
||||
liftIO $ print include
|
||||
|
||||
func <- liftIO $ runInterpreter (interpreter include entry)
|
||||
|
||||
case func of
|
||||
Right fn -> fn
|
||||
Right fn -> fn s
|
||||
Left err -> liftIO $ do
|
||||
putStrLn $ "error reading `call` from module " ++ entry
|
||||
print err
|
||||
case err of
|
||||
WontCompile errs -> mapM_ (putStrLn . errMsg) errs
|
||||
|
||||
x -> print x
|
||||
|
||||
liftIO $ setEnvironment backupEnv
|
||||
|
||||
return ()
|
||||
{-result <- build entry object ["-i" ++ source]-}
|
||||
{-print result-}
|
||||
|
||||
{-result :: (Maybe ) <- liftIO $ eval content ["System.Serverman.Types", "System.Serverman.Utils", "Control.Monad.State"]-}
|
||||
{-liftIO $ print result-}
|
||||
|
||||
interpreter :: [FilePath] -> FilePath -> Interpreter (App ())
|
||||
interpreter :: [FilePath] -> FilePath -> Interpreter (Service -> App ())
|
||||
interpreter path entry = do
|
||||
set [searchPath := path]
|
||||
loadModules [entry]
|
||||
setTopLevelModules ["Main"]
|
||||
interpret "call" (as :: App ())
|
||||
interpret "call" (as :: Service -> App ())
|
||||
|
||||
|
||||
@ -1,54 +0,0 @@
|
||||
module System.Serverman.Actions.Database (DatabaseParams(..), dummy) where
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Services
|
||||
|
||||
import Control.Monad.Free
|
||||
|
||||
data DatabaseParams = DatabaseParams { database :: String
|
||||
, databaseService :: Service
|
||||
, dummyData :: Bool
|
||||
, databaseUser :: String
|
||||
, databasePass :: String
|
||||
, databaseHost :: String
|
||||
} deriving (Eq)
|
||||
|
||||
dummy = ("serverman_users", ["first_name", "last_name", "email", "children", "birth_date", "gender"], [
|
||||
["MacKenzie","Wilcox","vel.sapien.imperdiet@bibendumsedest.com","4","1997-10-30T06:29:02-08:00","Male"],
|
||||
["Martha","Elliott","Phasellus@luctusetultrices.com","3","2000-03-04T00:53:32-08:00","Male"],
|
||||
["Declan","Nash","ut.quam@ultriciessemmagna.net","1","1975-08-02T00:27:02-07:00","Female"],
|
||||
["Kasimir","Fisher","sit.amet.consectetuer@sapien.net","2","2015-06-09T21:45:41-07:00","Male"],
|
||||
["Uma","Kelley","vulputate@maurisa.ca","2","1990-05-27T06:28:00-07:00","Female"],
|
||||
["Hayley","Owen","eu.eros@velnisl.org","4","2013-07-02T06:13:04-07:00","Male"],
|
||||
["Pamela","Hebert","vestibulum.lorem@molestietellus.net","1","1998-01-21T05:32:18-08:00","Female"],
|
||||
["Sydnee","Irwin","ultrices@consectetueradipiscing.edu","4","1984-01-15T22:55:10-08:00","Female"],
|
||||
["Brandon","Sharp","non@nunc.co.uk","3","2000-06-21T10:05:13-07:00","Female"],
|
||||
["Gray","Guerrero","ipsum@magnaUttincidunt.net","1","1975-12-02T06:59:56-08:00","Female"],
|
||||
["Nomlanga","Mercado","dolor.Quisque.tincidunt@Donec.edu","1","2015-07-04T01:21:44-07:00","Male"],
|
||||
["Luke","Frazier","Aenean.sed.pede@Etiamvestibulum.co.uk","1","2007-01-22T22:03:24-08:00","Male"],
|
||||
["Cynthia","Farmer","vel@eratEtiam.co.uk","3","1975-06-20T06:40:51-07:00","Female"],
|
||||
["Timothy","Hopper","magna.Praesent.interdum@Phasellusvitaemauris.org","1","1991-03-18T15:36:03-08:00","Male"],
|
||||
["Graiden","Walton","est.mauris@aultricies.edu","1","1997-12-06T10:35:10-08:00","Female"],
|
||||
["Abigail","Webster","elementum.dui@Duissitamet.com","4","1978-05-03T13:39:42-07:00","Female"],
|
||||
["Samuel","Dyer","parturient.montes@Etiamligula.org","3","2002-08-30T21:34:17-07:00","Female"],
|
||||
["May","Blackburn","montes.nascetur.ridiculus@Aliquameratvolutpat.org","1","2004-11-01T13:10:43-08:00","Female"],
|
||||
["Regina","Hicks","Sed.nulla.ante@atpretium.edu","2","2005-08-28T02:52:49-07:00","Female"],
|
||||
["Roth","Bright","lacus@feugiattellus.edu","4","2010-07-26T14:27:31-07:00","Male"],
|
||||
["Sylvester","Chapman","Sed.eu@sitametdiam.edu","4","1975-01-23T19:36:26-08:00","Male"],
|
||||
["Martin","Sharp","Nullam@Vivamusnibh.net","2","2016-10-18T23:48:20-07:00","Male"],
|
||||
["Mary","Schroeder","sem.egestas.blandit@nullaatsem.com","1","1993-03-16T17:41:10-08:00","Female"],
|
||||
["Blythe","Alston","amet.faucibus.ut@ornareFuscemollis.org","1","1980-09-22T04:58:53-07:00","Female"],
|
||||
["Nathan","Ramsey","in.molestie@Mauris.ca","4","2006-05-07T08:30:57-07:00","Female"],
|
||||
["Zelenia","Meadows","nunc@Aenean.com","3","1983-04-03T01:42:18-08:00","Female"],
|
||||
["Karyn","Booker","tempor@sagittissemperNam.ca","3","2006-10-13T02:29:44-07:00","Male"],
|
||||
["Hiram","Booth","semper@risusDonecegestas.ca","4","2001-10-30T19:53:13-08:00","Male"],
|
||||
["Robert","Mcclure","semper@nonduinec.org","1","2012-11-14T17:32:09-08:00","Female"],
|
||||
["Celeste","Callahan","convallis@NulladignissimMaecenas.edu","1","1984-08-22T22:56:35-07:00","Female"],
|
||||
["Magee","Olsen","ligula.consectetuer.rhoncus@fermentumvel.com","2","1978-04-09T15:12:05-08:00","Female"],
|
||||
["Dana","Mccullough","ut.sem.Nulla@eleifendnec.net","4","2000-08-23T07:54:53-07:00","Male"],
|
||||
["Yen","Blanchard","et@Morbi.org","3","1997-05-09T03:30:56-07:00","Male"],
|
||||
["Cora","Valdez","lorem.vitae.odio@vulputateullamcorpermagna.net","2","1998-10-24T16:06:46-07:00","Male"],
|
||||
["Amela","Blackburn","vulputate.dui@ultrices.co.uk","3","2006-03-08T07:42:27-08:00","Male"],
|
||||
["Dean","Blanchard","ac.tellus@nonummyipsumnon.co.uk","2","2014-12-21T14:38:37-08:00","Female"],
|
||||
["Alika","Shields","est.mauris@mollis.co.uk","3","1976-11-08T22:32:16-08:00","Female"],
|
||||
["Byron","Dudley","mattis@nequeNullam.org","1","1992-07-04T12:32:20-07:00","Female"],
|
||||
["Noelle","Young","et.malesuada.fames@aliquetmolestietellus.net","2","2009-04-05T03:05:01-07:00","Female"]])
|
||||
@ -7,6 +7,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
|
||||
import System.IO.Error
|
||||
import Data.Either
|
||||
import Data.Char
|
||||
import Control.Monad.State
|
||||
|
||||
getOS = do
|
||||
arch_release <- execute "cat" ["/etc/os-release"] "" False
|
||||
@ -20,4 +21,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
|
||||
| "Mac" `isInfixOf` release = Mac
|
||||
| otherwise = Unknown
|
||||
|
||||
return distro
|
||||
state <- get
|
||||
put $ state { os = distro }
|
||||
|
||||
return ()
|
||||
|
||||
@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.FileSharing (FileSharingParams(..)) where
|
||||
import System.Serverman.Services
|
||||
import System.Serverman.Utils
|
||||
|
||||
data FileSharingParams = FileSharingParams { fDirectory :: FilePath
|
||||
, fUser :: String
|
||||
, fPass :: String
|
||||
, fPort :: String
|
||||
, fWritable :: Bool
|
||||
, fAnonymous :: Bool
|
||||
, fAnonymousWrite :: Bool
|
||||
, fRecreateUser :: Bool
|
||||
, fService :: Service
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show FileSharingParams where
|
||||
show (FileSharingParams { fDirectory, fUser, fPass, fPort, fWritable, fAnonymous, fAnonymousWrite, fService })
|
||||
| name fService == "vsftpd" =
|
||||
let boolToEnglish True = "YES"
|
||||
boolToEnglish False = "NO"
|
||||
in
|
||||
keyvalue [ ("anonymous_enable", boolToEnglish fAnonymous)
|
||||
, ("write_enable", boolToEnglish fWritable)
|
||||
, ("allow_writeable_chroot", boolToEnglish fWritable)
|
||||
, ("anon_upload_enable", boolToEnglish fAnonymousWrite)
|
||||
, ("anon_mkdir_write_enable", boolToEnglish fAnonymousWrite)
|
||||
, ("listen", "YES")
|
||||
, ("userlist_enable", "YES")
|
||||
, ("userlist_file", "/etc/vsftpd-serverman-user-list")
|
||||
, ("userlist_deny", "NO")
|
||||
, ("chroot_local_user", "YES")
|
||||
, ("xferlog_enable", "YES")
|
||||
, ("local_enable", "YES")] "="
|
||||
|
||||
| otherwise = "Unknown service provider"
|
||||
@ -6,6 +6,7 @@ module System.Serverman.Actions.Install (installService) where
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Services
|
||||
import System.Serverman.Actions.Env
|
||||
import System.Serverman.Actions.Repository
|
||||
import System.Serverman.Types
|
||||
|
||||
import System.IO.Error
|
||||
@ -14,10 +15,15 @@ module System.Serverman.Actions.Install (installService) where
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
|
||||
installService :: Service -> OS -> App ()
|
||||
installService s@(Service { dependencies, packages }) os = do
|
||||
forM_ dependencies (`installService` os)
|
||||
installService :: Service -> App ()
|
||||
installService s@(Service { dependencies, packages }) = do
|
||||
(AppState { os }) <- get
|
||||
|
||||
deps <- catMaybes <$> mapM findService dependencies
|
||||
forM_ deps installService
|
||||
|
||||
let base = case os of
|
||||
Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"])
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.Manage (startService, stopService) where
|
||||
import System.Serverman.Types
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Actions.Env
|
||||
import System.Serverman.Actions.Install
|
||||
@ -8,15 +9,25 @@ module System.Serverman.Actions.Manage (startService, stopService) where
|
||||
|
||||
import Control.Monad.State
|
||||
|
||||
startService :: Service -> OS -> App ()
|
||||
startService (Service { service }) os
|
||||
| os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
|
||||
| otherwise = executeRoot "systemctl" ["start", service] "" True
|
||||
>> execute "sleep" ["5s"] "" True
|
||||
>> return ()
|
||||
startService :: Service -> App ()
|
||||
startService (Service { service }) = do
|
||||
(AppState { os }) <- get
|
||||
case os of
|
||||
Mac -> do
|
||||
liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
|
||||
|
||||
stopService :: Service -> OS -> App ()
|
||||
stopService (Service { service }) os
|
||||
| os == Mac = liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically."
|
||||
| otherwise = executeRoot "systemctl" ["stop", service] "" True
|
||||
>> return ()
|
||||
_ -> do
|
||||
executeRoot "systemctl" ["start", service] "" True
|
||||
execute "sleep" ["5s"] "" True
|
||||
return ()
|
||||
|
||||
stopService :: Service -> App ()
|
||||
stopService (Service { service }) = do
|
||||
(AppState { os }) <- get
|
||||
case os of
|
||||
Mac -> do
|
||||
liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically."
|
||||
|
||||
_ -> do
|
||||
executeRoot "systemctl" ["stop", service] "" True
|
||||
return ()
|
||||
|
||||
@ -1,55 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.MongoDB (mongodb) where
|
||||
import System.Serverman.Actions.Database
|
||||
import System.Serverman.Utils hiding (execute)
|
||||
import Database.MongoDB
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.List hiding (delete)
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import System.IO.Error
|
||||
|
||||
mongodb :: DatabaseParams -> App ()
|
||||
mongodb (DatabaseParams { database, dummyData, databaseHost }) = liftIO $ do
|
||||
result <- tryIOError $ connect (readHostPort databaseHost)
|
||||
|
||||
case result of
|
||||
Right pipe -> do
|
||||
e <- access pipe master (T.pack database) run
|
||||
|
||||
close pipe
|
||||
Left err -> do
|
||||
putStrLn $ show err
|
||||
putStrLn $ "[Error] could not connect to MongoDB server " ++ databaseHost
|
||||
|
||||
where
|
||||
run = do
|
||||
when dummyData $ do
|
||||
clearCollection
|
||||
insertToCollection
|
||||
return ()
|
||||
|
||||
clearCollection = delete (select [] (T.pack collectionName))
|
||||
where (collectionName, _, _) = dummy
|
||||
|
||||
insertToCollection = insertMany (T.pack collectionName) records
|
||||
where
|
||||
(collectionName, definitions, rows) = dummy
|
||||
records = map (\row -> zipWith (\def value -> def =: row) (map T.pack definitions) row) rows
|
||||
|
||||
|
||||
createDummyTables = createTable dummy
|
||||
where
|
||||
createTable (tableName, columns, rows) = "CREATE TABLE IF NOT EXISTS " ++ tableName ++ "(" ++ intercalate "," (map columnDef columns) ++ ")";
|
||||
columnDef "children" = "children INT"
|
||||
columnDef "birth_date" = "birth_date DATETIME"
|
||||
columnDef "gender" = "gender ENUM('Male', 'Female')"
|
||||
columnDef name = name ++ " VARCHAR(255)"
|
||||
|
||||
insertToDummyTables = insertTable dummy
|
||||
where
|
||||
insertTable (tableName, _, rows) = "INSERT INTO " ++ tableName ++ " VALUES " ++ intercalate "," (map insertRow rows)
|
||||
insertRow row = "('" ++ intercalate "','" row ++ "')"
|
||||
|
||||
@ -1,46 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.MySQL (mysql) where
|
||||
import System.Serverman.Actions.Database
|
||||
import System.Serverman.Utils hiding (execute)
|
||||
import Database.MySQL.Base
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.List
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
|
||||
mysql :: DatabaseParams -> App ()
|
||||
mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = liftIO $ do
|
||||
conn <- connect $ defaultConnectInfo { connectUser = databaseUser, connectPassword = databasePass, connectHost = databaseHost }
|
||||
|
||||
query conn $ BS.pack ("CREATE DATABASE IF NOT EXISTS " ++ database)
|
||||
|
||||
|
||||
when dummyData $ do
|
||||
let (tableName, _, _) = dummy
|
||||
|
||||
query conn $ BS.pack createDummyTables
|
||||
query conn $ BS.pack clearTable
|
||||
query conn $ BS.pack insertToDummyTables
|
||||
|
||||
putStrLn $ "Created dummy table '" ++ tableName ++ "' and filled it with data."
|
||||
return ()
|
||||
|
||||
return ()
|
||||
|
||||
clearTable = "DELETE FROM " ++ tableName
|
||||
where (tableName, _, _) = dummy
|
||||
|
||||
createDummyTables = createTable dummy
|
||||
where
|
||||
createTable (tableName, columns, rows) = "CREATE TABLE IF NOT EXISTS " ++ tableName ++ "(" ++ intercalate "," (map columnDef columns) ++ ")";
|
||||
columnDef "children" = "children INT"
|
||||
columnDef "birth_date" = "birth_date DATETIME"
|
||||
columnDef "gender" = "gender ENUM('Male', 'Female')"
|
||||
columnDef name = name ++ " VARCHAR(255)"
|
||||
|
||||
insertToDummyTables = insertTable dummy
|
||||
where
|
||||
insertTable (tableName, _, rows) = "INSERT INTO " ++ tableName ++ " VALUES " ++ intercalate "," (map insertRow rows)
|
||||
insertRow row = "('" ++ intercalate "','" row ++ "')"
|
||||
|
||||
@ -1,120 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module System.Serverman.Actions.Nginx (nginx) where
|
||||
import System.Serverman.Action
|
||||
import System.Serverman.Actions.WebServer
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Services
|
||||
|
||||
import System.Directory
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Free
|
||||
import Data.List
|
||||
|
||||
nginx :: ServerParams -> App ()
|
||||
nginx params@(ServerParams { ssl, serverService, domain, wDirectory, serverType, email }) =
|
||||
do
|
||||
-- Turn SSL off at first, because we have not yet received a certificate
|
||||
let content = show (params { ssl = False, port = "80" })
|
||||
mainConfig = config serverService </> "nginx.conf"
|
||||
parent = config serverService </> "serverman-configs"
|
||||
path = parent </> domain
|
||||
targetDir = wDirectory
|
||||
|
||||
liftIO $ do
|
||||
createDirectoryIfMissing True targetDir
|
||||
createDirectoryIfMissing True parent
|
||||
|
||||
writeIncludeStatementIfMissing mainConfig parent
|
||||
|
||||
when ssl $ do
|
||||
let sslPath = config serverService </> "ssl.conf"
|
||||
writeFileIfMissing sslPath nginxSSL
|
||||
putStrLn $ "wrote ssl configuration to " ++ sslPath
|
||||
|
||||
writeFile path content
|
||||
|
||||
putStrLn $ "wrote your configuration file to " ++ path
|
||||
|
||||
liftIO . wait =<< restart
|
||||
|
||||
when ssl $ do
|
||||
let dhparamPath = "/etc/ssl/certs/dhparam.pem"
|
||||
dhExists <- liftIO $ doesFileExist dhparamPath
|
||||
|
||||
when (not dhExists) $ do
|
||||
dhparam <- liftedAsync $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True
|
||||
liftIO $ wait dhparam
|
||||
return ()
|
||||
|
||||
case serverType of
|
||||
Static -> do
|
||||
letsencrypt <- liftedAsync $ createCert path "letsencrypt"
|
||||
|
||||
liftIO $ wait letsencrypt
|
||||
return ()
|
||||
_ -> liftIO $ do
|
||||
putStrLn $ "you should use letsencrypt to create a certificate for your domain"
|
||||
putStrLn $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem"
|
||||
putStrLn $ "my suggestion is running this command:"
|
||||
putStrLn $ "sudo letsencrypt certonly --webroot --webroot-path <YOUR_APPLICATION_DIRECTORY> -d " ++ domain
|
||||
|
||||
liftIO $ putStrLn $ "for more information, see: https://certbot.eff.org/"
|
||||
|
||||
return ()
|
||||
where
|
||||
restart = liftedAsync $ do
|
||||
result <- restartService "nginx"
|
||||
case result of
|
||||
Left err -> return ()
|
||||
Right _ ->
|
||||
liftIO $ putStrLn $ "restarted " ++ show serverService
|
||||
|
||||
createCert path cmd = do
|
||||
result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", wDirectory, "-d", domain, "--email", email, "--agree-tos", "-n"] "" False
|
||||
case result of
|
||||
Left _ -> if cmd == "letsencrypt" then createCert path "certbot" else return ()
|
||||
Right stdout -> do
|
||||
liftIO $ putStrLn stdout
|
||||
|
||||
when (not ("error" `isInfixOf` stdout)) $ do
|
||||
liftIO $ writeFile path (show params)
|
||||
liftIO . wait =<< restart
|
||||
return ()
|
||||
|
||||
writeIncludeStatementIfMissing path target = do
|
||||
content <- readFile path
|
||||
|
||||
let statement = "include " ++ target ++ "/*;"
|
||||
|
||||
when (not (statement `isInfixOf` content)) $ do
|
||||
let newContent = appendAfter content "http {" (indent . indent $ statement)
|
||||
|
||||
writeFile path newContent
|
||||
|
||||
nginxSSL = "# from https://cipherli.st/\n\
|
||||
\# and https://raymii.org/s/tutorials/Strong_SSL_Security_On_nginx.html\n\
|
||||
\\n\
|
||||
\ssl_protocols TLSv1 TLSv1.1 TLSv1.2;\n\
|
||||
\ssl_prefer_server_ciphers on;\n\
|
||||
\ssl_ciphers 'EECDH+AESGCM:EDH+AESGCM:AES256+EECDH:AES256+EDH';\n\
|
||||
\ssl_ecdh_curve secp384r1;\n\
|
||||
\ssl_session_cache shared:SSL:10m;\n\
|
||||
\ssl_session_tickets off;\n\
|
||||
\ssl_stapling on;\n\
|
||||
\ssl_stapling_verify on;\n\
|
||||
\resolver 8.8.8.8 8.8.4.4 valid=300s;\n\
|
||||
\resolver_timeout 5s;\n\
|
||||
\# Disable preloading HSTS for now. You can use the commented out header line that includes\n\
|
||||
\# the 'preload' directive if you understand the implications.\n\
|
||||
\#add_header Strict-Transport-Security 'max-age=63072000; includeSubdomains; preload';\n\
|
||||
\add_header Strict-Transport-Security 'max-age=63072000; includeSubdomains';\n\
|
||||
\add_header X-Frame-Options DENY;\n\
|
||||
\add_header X-Content-Type-Options nosniff;\n\
|
||||
\\n\
|
||||
\ssl_dhparam /etc/ssl/certs/dhparam.pem;\n"
|
||||
@ -2,7 +2,7 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.Repository (fetchRepo) where
|
||||
module System.Serverman.Actions.Repository (fetchRepo, findService) where
|
||||
import System.Serverman.Utils
|
||||
import System.Directory
|
||||
import System.Serverman.Services
|
||||
@ -19,9 +19,15 @@ module System.Serverman.Actions.Repository (fetchRepo) where
|
||||
import Control.Monad.State
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS
|
||||
import qualified Data.Text as T
|
||||
import Data.List
|
||||
|
||||
sourceURL = "https://github.com/mdibaiee/serverman"
|
||||
|
||||
findService :: String -> App (Maybe Service)
|
||||
findService n = do
|
||||
(AppState { repository }) <- get
|
||||
return $ find (\a -> name a == n) repository
|
||||
|
||||
fetchRepo :: App Repository
|
||||
fetchRepo = do
|
||||
state@(AppState { repositoryURL }) <- get
|
||||
@ -53,6 +59,7 @@ module System.Serverman.Actions.Repository (fetchRepo) where
|
||||
case repo of
|
||||
Just list -> do
|
||||
let r = rights list
|
||||
|
||||
state <- get
|
||||
put $ state { repository = r }
|
||||
return $ rights list
|
||||
@ -70,17 +77,17 @@ module System.Serverman.Actions.Repository (fetchRepo) where
|
||||
flip parseEither obj $ \object -> do
|
||||
name <- object .: "name"
|
||||
version <- object .: "version"
|
||||
config <- object .: "config"
|
||||
service <- object .: "service"
|
||||
category <- object .: "category"
|
||||
packages <- object .: "packages"
|
||||
dependencies <- object .: "dependencies"
|
||||
|
||||
pkglist :: [(OS, [String])] <- map (\(os, name) -> (read os, name)) <$> M.toList <$> parseJSON packages
|
||||
|
||||
return Service { name = name
|
||||
, version = version
|
||||
, config = config
|
||||
, service = service
|
||||
, category = category
|
||||
, packages = pkglist
|
||||
, dependencies = dependencies
|
||||
}
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.Manage (startService, stopService) where
|
||||
import System.Serverman.Types
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Actions.Env
|
||||
import System.Serverman.Actions.Install
|
||||
@ -8,15 +9,25 @@ module System.Serverman.Actions.Manage (startService, stopService) where
|
||||
|
||||
import Control.Monad.State
|
||||
|
||||
startService :: Service -> OS -> App ()
|
||||
startService (Service { service }) os
|
||||
| os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
|
||||
| otherwise = executeRoot "systemctl" ["start", service] "" True
|
||||
>> execute "sleep" ["5s"] "" True
|
||||
>> return ()
|
||||
startService :: Service -> App ()
|
||||
startService (Service { service }) = do
|
||||
(AppState { os }) <- get
|
||||
case os of
|
||||
Mac -> do
|
||||
liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
|
||||
|
||||
stopService :: Service -> OS -> App ()
|
||||
stopService (Service { service }) os
|
||||
| os == Mac = liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically."
|
||||
| otherwise = executeRoot "systemctl" ["stop", service] "" True
|
||||
>> return ()
|
||||
_ -> do
|
||||
executeRoot "systemctl" ["start", service] "" True
|
||||
execute "sleep" ["5s"] "" True
|
||||
return ()
|
||||
|
||||
stopService :: Service -> App ()
|
||||
stopService (Service { service }) = do
|
||||
(AppState { os }) <- get
|
||||
case os of
|
||||
Mac -> do
|
||||
liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically."
|
||||
|
||||
_ -> do
|
||||
executeRoot "systemctl" ["stop", service] "" True
|
||||
return ()
|
||||
|
||||
@ -1,43 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.VsFTPd (vsftpd) where
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Services
|
||||
import System.Serverman.Actions.FileSharing
|
||||
|
||||
import System.Directory
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
import Control.Monad.Free
|
||||
import Data.List
|
||||
import Data.Either
|
||||
import Control.Monad.State
|
||||
|
||||
vsftpd :: FileSharingParams -> App ()
|
||||
vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) =
|
||||
do
|
||||
let content = show params
|
||||
original = config fService
|
||||
userList = takeDirectory original </> "vsftpd-serverman-user-list"
|
||||
|
||||
when fRecreateUser $ executeRoot "userdel" [fUser] "" True >> return ()
|
||||
|
||||
(Right opensslResponse) <- execute "openssl" ["passwd", "-1", fPass] "" True
|
||||
let encryptedPassword = head . lines $ opensslResponse
|
||||
|
||||
executeRoot "useradd" [fUser, "-d", fDirectory, "-G", "ftp", "-p", encryptedPassword] "" True
|
||||
|
||||
liftIO $ do
|
||||
renameFileIfMissing original (original ++ ".backup")
|
||||
writeFile original content
|
||||
writeFile userList fUser
|
||||
|
||||
result <- restartService "vsftpd"
|
||||
case result of
|
||||
Left err -> return ()
|
||||
Right _ ->
|
||||
liftIO $ putStrLn $ "restarted " ++ show fService
|
||||
@ -1,59 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) where
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Services
|
||||
|
||||
import Control.Monad.Free
|
||||
|
||||
data ServerType = Static | PortForwarding deriving (Show, Eq)
|
||||
data ServerParams = ServerParams { wDirectory :: FilePath
|
||||
, domain :: String
|
||||
, port :: String
|
||||
, forward :: String
|
||||
, email :: String
|
||||
, ssl :: Bool
|
||||
, serverType :: ServerType
|
||||
, serverService :: Service
|
||||
} deriving (Eq)
|
||||
instance Show ServerParams where
|
||||
show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService })
|
||||
| name serverService == "nginx" =
|
||||
let redirect
|
||||
| ssl = block "server" $
|
||||
semicolon $
|
||||
keyvalue ([ ("listen", "80")
|
||||
, ("listen", "[::]:80")
|
||||
, ("server_name", domain)
|
||||
, ("rewrite", "^ https://$server_name$request_uri? permanent")
|
||||
]) " "
|
||||
| otherwise = ""
|
||||
https
|
||||
| ssl = [ ("ssl_certificate", "/etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem")
|
||||
, ("ssl_certificate_key", "/etc/letsencrypt/live/" ++ domain ++ "/privkey.pem")
|
||||
, ("include", "ssl.conf")]
|
||||
| otherwise = []
|
||||
|
||||
listen = port ++ (if ssl then " ssl" else "")
|
||||
|
||||
base = [ ("server_name", domain)
|
||||
, ("listen", listen)
|
||||
, ("listen", "[::]:" ++ listen)
|
||||
, ("index", "index.html index.html index.php")
|
||||
] ++ https
|
||||
in
|
||||
case serverType of
|
||||
Static ->
|
||||
(block "server" $ keyvalue (base ++ [("root", wDirectory)]) " ") ++ "\n" ++ redirect
|
||||
|
||||
PortForwarding ->
|
||||
let proxyBlock = block "location /" $
|
||||
semicolon $
|
||||
keyvalue ([ ("proxy_pass", "http://127.0.0.1:" ++ forward)
|
||||
, ("proxy_set_header", "X-Forwarded-Host $host")
|
||||
, ("proxy_set_header", "X-Forwarded-Server $host")
|
||||
, ("proxy_set_header", "X-Forwarded-For $proxy_add_x_forwarded_for")
|
||||
]) " "
|
||||
in (block "server" $ semicolon (keyvalue base " ") ++ proxyBlock) ++ "\n" ++ redirect
|
||||
|
||||
| otherwise = "Unknown service provider"
|
||||
@ -17,11 +17,10 @@ module System.Serverman.Services ( Service(..)
|
||||
packageByOS (Service { packages }) os = fromMaybe (fromJust $ lookup Unknown packages) (lookup os packages)
|
||||
|
||||
info :: Service -> String
|
||||
info s@(Service { config, packages, service, version, dependencies }) =
|
||||
info s@(Service { packages, service, version, dependencies }) =
|
||||
show s ++ (
|
||||
indent $
|
||||
keyvalue [ ("config", config)
|
||||
, ("pacakges", commas $ map (commas . snd) packages)
|
||||
keyvalue [ ("pacakges", commas $ map (commas . snd) packages)
|
||||
, ("service", service)
|
||||
, ("dependencies", commas $ map name dependencies)] ": "
|
||||
, ("dependencies", commas dependencies)] ": "
|
||||
)
|
||||
|
||||
@ -57,11 +57,10 @@ module System.Serverman.Types ( Service (..)
|
||||
| os == Unknown = "_"
|
||||
|
||||
data Service = Service { name :: String
|
||||
, config :: String
|
||||
, packages :: [(OS, [String])]
|
||||
, service :: String
|
||||
, version :: String
|
||||
, dependencies :: [Service]
|
||||
, dependencies :: [String]
|
||||
, category :: String
|
||||
} deriving (Eq, Generic)
|
||||
|
||||
@ -74,15 +73,19 @@ module System.Serverman.Types ( Service (..)
|
||||
|
||||
type Repository = [Service]
|
||||
|
||||
data AppState = AppState { remoteMode :: Maybe (Address, String)
|
||||
, repository :: Repository
|
||||
data AppState = AppState { remoteMode :: Maybe (Address, String)
|
||||
, repository :: Repository
|
||||
, repositoryURL :: String
|
||||
, os :: OS
|
||||
, arguments :: [(String, Maybe String)]
|
||||
} deriving (Show)
|
||||
|
||||
instance Default AppState where
|
||||
def = AppState { remoteMode = Nothing
|
||||
, repository = def
|
||||
def = AppState { remoteMode = Nothing
|
||||
, repository = def
|
||||
, repositoryURL = "https://github.com/mdibaiee/serverman-repository"
|
||||
, os = Unknown
|
||||
, arguments = []
|
||||
}
|
||||
type App = StateT AppState IO
|
||||
|
||||
|
||||
@ -17,6 +17,7 @@ module System.Term ( initialize ) where
|
||||
import Data.List
|
||||
|
||||
import System.Serverman.Utils
|
||||
import System.Serverman.Actions.Repository
|
||||
|
||||
initialize = do
|
||||
args <- getArgs
|
||||
@ -24,29 +25,39 @@ module System.Term ( initialize ) where
|
||||
dir <- liftIO $ getAppUserDataDirectory "serverman"
|
||||
let path = dir </> "repository"
|
||||
|
||||
liftIO $ print args
|
||||
let params = parseParams args
|
||||
liftIO $ print params
|
||||
|
||||
-- Fetch repository first
|
||||
S.runApp $ do
|
||||
S.run (S.fetchRepository)
|
||||
S.run (S.detectOS)
|
||||
|
||||
state@(S.AppState { S.repository }) <- get
|
||||
put $ state { arguments = rest params }
|
||||
|
||||
case params of
|
||||
(Params { listServices = True }) -> liftIO $ do
|
||||
mapM_ print repository
|
||||
(Params { install = Just service }) -> do
|
||||
os <- S.run S.detectOS
|
||||
S.run (S.install (findService repository service) os)
|
||||
ms <- findService service
|
||||
case ms of
|
||||
Just s -> S.run (S.install s)
|
||||
Nothing -> liftIO $ putStrLn $ "service not found: " ++ service
|
||||
(Params { rest = (x:xs) }) -> do
|
||||
case x of
|
||||
(service, Nothing) -> do
|
||||
ms <- findService service
|
||||
case ms of
|
||||
Just s -> S.run (S.call s)
|
||||
Nothing -> liftIO $ putStrLn $ "could not find any service matching " ++ service
|
||||
_ -> liftIO $ putStrLn $ "could not understand your input"
|
||||
|
||||
{-S.run (S.call (head repository) [])-}
|
||||
|
||||
return ()
|
||||
|
||||
where
|
||||
findService repository n = fromJust $ find (\a -> S.name a == n) repository
|
||||
|
||||
|
||||
data Manage = Start | Stop deriving (Eq, Show)
|
||||
@ -56,6 +67,7 @@ module System.Term ( initialize ) where
|
||||
, update :: Bool
|
||||
, remote :: Maybe FilePath
|
||||
, help :: Bool
|
||||
, rest :: [(String, Maybe String)]
|
||||
} deriving (Show)
|
||||
|
||||
instance Default Params where
|
||||
@ -65,6 +77,7 @@ module System.Term ( initialize ) where
|
||||
, remote = Nothing
|
||||
, update = False
|
||||
, help = False
|
||||
, rest = []
|
||||
}
|
||||
|
||||
parseParams :: [String] -> Params
|
||||
@ -76,8 +89,20 @@ module System.Term ( initialize ) where
|
||||
parseParams ("--remote":s:xs) = (parseParams xs) { remote = Just s }
|
||||
parseParams ("--help":xs) = (parseParams xs) { help = True }
|
||||
parseParams ("-h":xs) = (parseParams xs) { help = True }
|
||||
parseParams [] = def
|
||||
parseParams _ = Params { help = True }
|
||||
parseParams [] = def { help = True }
|
||||
parseParams x = def { rest = toPairs x }
|
||||
where
|
||||
toPairs [] = []
|
||||
toPairs [x] = [(getWord x, Nothing)]
|
||||
toPairs (x:y:xs)
|
||||
| flagName x && value y = [(getWord x, Just y)] ++ toPairs xs
|
||||
| flagName y && value x = [(getWord x, Nothing)] ++ toPairs (y:xs)
|
||||
| flagName x && flagName y = [(getWord x, Nothing)] ++ toPairs (y:xs)
|
||||
| otherwise = toPairs xs
|
||||
|
||||
flagName = isPrefixOf "-"
|
||||
value = not . flagName
|
||||
getWord = dropWhile (== '-')
|
||||
|
||||
{-WEB SERVER -}
|
||||
{-data Params = WebServerParams { directory :: String-}
|
||||
|
||||
@ -1,45 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Term.Database (mode, handle, Params(..)) where
|
||||
import System.Console.CmdArgs hiding (name)
|
||||
import qualified System.Console.CmdArgs as C (name)
|
||||
import qualified System.Serverman as S
|
||||
import qualified System.Term.Remote as R
|
||||
import Control.Monad
|
||||
import System.Exit
|
||||
import System.Directory
|
||||
|
||||
data Params = Params { name :: String
|
||||
, service :: String
|
||||
, dummyData :: Bool
|
||||
, user :: String
|
||||
, pass :: String
|
||||
, host :: String
|
||||
, remote :: FilePath
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
mode = Params { name = "test" &= help "database name, defaults to test"
|
||||
, service = "mysql" &= help "service to setup: mysql, defaults to mysql"
|
||||
, dummyData = False &= help "generate dummy data in the database" &= explicit &= C.name "dummy-data"
|
||||
, user = "root" &= help "database's username, defaults to root"
|
||||
, pass = "" &= help "database's password, defaults to blank string"
|
||||
, host = "127.0.0.1" &= help "database's host, defaults to localhost"
|
||||
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir
|
||||
} &= explicit &= C.name "database"
|
||||
|
||||
handle (Params { name, service, dummyData, user, pass, host, remote }) =
|
||||
R.handle remote $ do
|
||||
let serviceName = read service
|
||||
|
||||
let params = S.DatabaseParams { S.database = name
|
||||
, S.databaseService = serviceName
|
||||
, S.dummyData = dummyData
|
||||
, S.databaseUser = user
|
||||
, S.databasePass = pass
|
||||
, S.databaseHost = host
|
||||
}
|
||||
|
||||
return $ S.detectOS >>= (S.install serviceName)
|
||||
>> S.detectOS >>= (S.start serviceName)
|
||||
>> S.newDatabase params
|
||||
@ -1,53 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Term.FileSharing (mode, handle, Params(..)) where
|
||||
import System.Console.CmdArgs
|
||||
import qualified System.Serverman as S
|
||||
import qualified System.Term.Remote as R
|
||||
import Control.Monad
|
||||
import System.Exit
|
||||
import System.Directory hiding (writable)
|
||||
|
||||
data Params = Params { directory :: String
|
||||
, user :: String
|
||||
, pass :: String
|
||||
, port :: String
|
||||
, writable :: Bool
|
||||
, anonymous :: Bool
|
||||
, anonymousWrite :: Bool
|
||||
, recreateUser :: Bool
|
||||
, service :: String
|
||||
, remote :: FilePath
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
mode = Params { directory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory"
|
||||
, user = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user"
|
||||
, pass = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password"
|
||||
, anonymous = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous"
|
||||
, anonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write"
|
||||
, writable = True &= help "allow write operations, defaults to True" &= explicit &= name "writable"
|
||||
, port = "21" &= help "service port, defaults to 21" &= explicit &= name "port"
|
||||
, service = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service"
|
||||
, recreateUser = False &= help "recreate the user" &= explicit &= name "recreate-user"
|
||||
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
|
||||
} &= explicit &= name "filesharing"
|
||||
|
||||
handle (Params { directory, user, pass, port, anonymous, anonymousWrite, writable, service, recreateUser, remote }) =
|
||||
R.handle remote $ do
|
||||
let serviceName = read service
|
||||
|
||||
let params = S.FileSharingParams { S.fDirectory = directory
|
||||
, S.fUser = user
|
||||
, S.fPass = pass
|
||||
, S.fPort = port
|
||||
, S.fAnonymous = anonymous
|
||||
, S.fAnonymousWrite = anonymousWrite
|
||||
, S.fWritable = writable
|
||||
, S.fService = serviceName
|
||||
, S.fRecreateUser = recreateUser
|
||||
}
|
||||
|
||||
return $ S.detectOS >>= (S.install serviceName)
|
||||
>> S.detectOS >>= (S.start serviceName)
|
||||
>> S.newFileSharing params
|
||||
@ -1,27 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Term.Install (mode, handle, Params(..)) where
|
||||
import System.Console.CmdArgs
|
||||
import qualified System.Serverman as S
|
||||
import qualified System.Term.Remote as R
|
||||
import Control.Monad
|
||||
import System.Exit
|
||||
import System.Directory
|
||||
|
||||
data Params = Params { service :: String
|
||||
, remote :: FilePath
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
mode = Params { service = def &= argPos 0
|
||||
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
|
||||
}
|
||||
|
||||
handle (Params { service, remote }) =
|
||||
R.handle remote $ do
|
||||
let serviceName = read service
|
||||
|
||||
return $ S.detectOS >>= (S.install serviceName)
|
||||
>> S.detectOS >>= (S.start serviceName)
|
||||
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
module System.Term.Remote (handle) where
|
||||
import qualified System.Serverman as S
|
||||
|
||||
handle file generateAction
|
||||
| null file = S.run =<< generateAction
|
||||
| otherwise = do
|
||||
list <- map read . lines <$> readFile file
|
||||
action <- generateAction
|
||||
|
||||
S.run $ S.remote list action
|
||||
@ -1,60 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module System.Term.WebServer (mode, handle, Params(..)) where
|
||||
import System.Console.CmdArgs
|
||||
import qualified System.Serverman as S
|
||||
import qualified System.Term.Remote as R
|
||||
import Control.Monad
|
||||
import System.Exit
|
||||
import System.Directory
|
||||
|
||||
data Params = Params { directory :: String
|
||||
, domain :: String
|
||||
, port :: String
|
||||
, forward :: String
|
||||
, service :: String
|
||||
, ssl :: Bool
|
||||
, email :: String
|
||||
, remote :: FilePath
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
mode = Params { directory = "/var/www/html/" &= typDir &= help "directory to serve static files from, defaults to /var/www/html/"
|
||||
, domain = "test.dev" &= typ "DOMAIN" &= help "domain/server name, defaults to test.dev"
|
||||
, port = def &= typ "PORT" &= help "port number to listen to, defaults to 80 for http and 443 for https"
|
||||
, forward = def &= typ "PORT" &= help "the port to forward to (in case of a port-forwarding server)"
|
||||
, ssl = False &= help "create a letsencrypt certificate for this domain, defaults to false"
|
||||
, email = def &= help "email required for registering your certificate"
|
||||
, service = "nginx" &= help "service to build config for: nginx, defaults to nginx"
|
||||
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
|
||||
} &= explicit &= name "webserver"
|
||||
|
||||
handle (Params { directory, domain, port, ssl, forward, service, email, remote }) =
|
||||
R.handle remote $ do
|
||||
when (ssl && null email) $ die "Email is required for generating a certificate"
|
||||
|
||||
let serverType
|
||||
| (not . null) forward = S.PortForwarding
|
||||
| otherwise = S.Static
|
||||
|
||||
let serviceName = read service :: S.Service
|
||||
|
||||
let portNumber
|
||||
| (not . null) port = port
|
||||
| ssl = "443"
|
||||
| otherwise = "80"
|
||||
|
||||
absoluteDirectory <- makeAbsolute directory
|
||||
|
||||
let params = S.ServerParams { S.wDirectory = absoluteDirectory
|
||||
, S.domain = domain
|
||||
, S.port = portNumber
|
||||
, S.ssl = ssl
|
||||
, S.forward = forward
|
||||
, S.serverType = serverType
|
||||
, S.serverService = serviceName
|
||||
, S.email = email
|
||||
}
|
||||
return $ S.detectOS >>= (S.install serviceName)
|
||||
>> S.detectOS >>= (S.start serviceName)
|
||||
>> S.newServer params
|
||||
Loading…
Reference in New Issue
Block a user