feat: repository
This commit is contained in:
		| @@ -20,20 +20,14 @@ library | ||||
|                      , System.Serverman.Utils | ||||
|                      , System.Serverman.Action | ||||
|                       | ||||
|                      , System.Serverman.Actions.WebServer | ||||
|                      , System.Serverman.Actions.Nginx | ||||
|  | ||||
|                      , System.Serverman.Actions.Database | ||||
|                      , System.Serverman.Actions.MySQL | ||||
|                      , System.Serverman.Actions.MongoDB | ||||
|  | ||||
|                      , System.Serverman.Actions.FileSharing | ||||
|                      , System.Serverman.Actions.VsFTPd | ||||
|  | ||||
|                      , System.Serverman.Actions.Install | ||||
|                      , System.Serverman.Actions.Env | ||||
|                      , System.Serverman.Actions.Start | ||||
|                      , System.Serverman.Actions.Manage | ||||
|                      , System.Serverman.Actions.Remote | ||||
|                      , System.Serverman.Actions.Repository | ||||
|                      , System.Serverman.Actions.Call | ||||
|  | ||||
|                      , System.Serverman.Types | ||||
|                      , System.Serverman.Services | ||||
|   build-depends:       base >= 4.7 && < 5 | ||||
|                      , free >= 4.12.4 && < 5 | ||||
| @@ -52,6 +46,10 @@ library | ||||
|                      , Unixutils | ||||
|                      , mtl | ||||
|                      , monad-control | ||||
|                      , aeson | ||||
|                      , containers | ||||
|                      , hint | ||||
|                      , stack | ||||
|   default-language:    Haskell2010 | ||||
|  | ||||
| executable serverman | ||||
|   | ||||
| @@ -2,30 +2,20 @@ module System.Serverman ( run | ||||
|                         , module System.Serverman.Action | ||||
|                         , module System.Serverman.Utils | ||||
|                         , module System.Serverman.Services | ||||
|                         , module System.Serverman.Actions.WebServer | ||||
|                         , module System.Serverman.Actions.Database | ||||
|                         , module System.Serverman.Actions.FileSharing | ||||
|                         , module System.Serverman.Actions.Env | ||||
|                         , module System.Serverman.Actions.Install) where | ||||
|  | ||||
|   import System.Serverman.Action | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Services | ||||
|   import System.Serverman.Types | ||||
|  | ||||
|   import System.Serverman.Actions.Env | ||||
|   import System.Serverman.Actions.Install | ||||
|   import System.Serverman.Actions.Start | ||||
|   import System.Serverman.Actions.Manage | ||||
|   import System.Serverman.Actions.Repository | ||||
|   import System.Serverman.Actions.Remote | ||||
|  | ||||
|   import System.Serverman.Actions.WebServer | ||||
|   import System.Serverman.Actions.Nginx | ||||
|  | ||||
|   import System.Serverman.Actions.Database | ||||
|   import System.Serverman.Actions.MySQL | ||||
|   import System.Serverman.Actions.MongoDB | ||||
|  | ||||
|   import System.Serverman.Actions.FileSharing | ||||
|   import System.Serverman.Actions.VsFTPd | ||||
|   import System.Serverman.Actions.Call | ||||
|  | ||||
|   import Control.Monad.Free | ||||
|  | ||||
| @@ -33,20 +23,12 @@ module System.Serverman ( run | ||||
|   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 (NewWebServer params next)) | ||||
|     | serverService params == NGINX = nginx params >> run next | ||||
|     | otherwise = run next | ||||
|  | ||||
|   run (Free (NewDatabase params next)) | ||||
|     | databaseService params == MySQL = mysql params >> run next | ||||
|     | databaseService params == MongoDB = mongodb params >> run next | ||||
|     | otherwise = run next | ||||
|  | ||||
|   run (Free (NewFileSharing params next)) | ||||
|     | fService params == VsFTPd = vsftpd params >> run next | ||||
|     | otherwise = run next | ||||
|   run (Free (Call service params next)) = callService service params >> run next | ||||
|  | ||||
|   run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next | ||||
|  | ||||
|   run (Free (FetchRepository next)) = fetchRepo >> run next | ||||
|  | ||||
|   | ||||
| @@ -2,20 +2,20 @@ | ||||
|  | ||||
| module System.Serverman.Action ( ActionF(..) | ||||
|                                , Action | ||||
|                                , newServer | ||||
|                                , newDatabase | ||||
|                                , newFileSharing | ||||
|                                , call | ||||
|                                , fetchRepository | ||||
|                                , start | ||||
|                                , stop | ||||
|                                , install | ||||
|                                , remote | ||||
|                                , detectOS) where | ||||
|  | ||||
|   import System.Serverman.Actions.WebServer | ||||
|   import System.Serverman.Actions.FileSharing | ||||
|   import System.Serverman.Actions.Database | ||||
|   import System.Serverman.Actions.Env | ||||
|   import System.Serverman.Actions.Repository | ||||
|   import System.Serverman.Actions.Remote | ||||
|  | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Types | ||||
|   import System.Serverman.Services | ||||
|  | ||||
|   import System.Directory | ||||
| @@ -28,33 +28,27 @@ module System.Serverman.Action ( ActionF(..) | ||||
|   import System.IO.Error | ||||
|   import Data.Char | ||||
|  | ||||
|   data ActionF x = NewWebServer ServerParams x | ||||
|                  | NewDatabase DatabaseParams x | ||||
|                  | NewFileSharing FileSharingParams x | ||||
|   data ActionF x = Call Service Params x | ||||
|                  | DetectOS (OS -> x) | ||||
|                  | Install Service OS x | ||||
|                  | Remote [Address] (Action ()) x | ||||
|                  | FetchRepository x | ||||
|                  | Start Service OS x | ||||
|                  | Stop Service OS x | ||||
|  | ||||
|   instance Functor ActionF where | ||||
|     fmap f (NewWebServer params x) = NewWebServer params (f x) | ||||
|     fmap f (NewDatabase params x) = NewDatabase params (f x) | ||||
|     fmap f (NewFileSharing params x) = NewFileSharing params (f x) | ||||
|     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 (Remote addr action x) = Remote addr action (f x) | ||||
|     fmap f (FetchRepository x) = FetchRepository (f x) | ||||
|  | ||||
|   type Action = Free ActionF | ||||
|  | ||||
|   newServer :: ServerParams -> Action () | ||||
|   newServer params = liftF $ NewWebServer params () | ||||
|  | ||||
|   newDatabase :: DatabaseParams -> Action () | ||||
|   newDatabase params = liftF $ NewDatabase params () | ||||
|  | ||||
|   newFileSharing :: FileSharingParams -> Action () | ||||
|   newFileSharing params = liftF $ NewFileSharing params () | ||||
|   call :: Service -> Params -> Action () | ||||
|   call service params = liftF $ Call service params () | ||||
|  | ||||
|   install :: Service -> OS -> Action () | ||||
|   install service os = liftF $ Install service os () | ||||
| @@ -62,8 +56,14 @@ module System.Serverman.Action ( ActionF(..) | ||||
|   start :: Service -> OS -> Action () | ||||
|   start service os = liftF $ Start service os () | ||||
|  | ||||
|   stop :: Service -> OS -> Action () | ||||
|   stop service os = liftF $ Stop service os () | ||||
|  | ||||
|   detectOS :: Action OS | ||||
|   detectOS = liftF $ DetectOS id | ||||
|  | ||||
|   remote :: [Address] -> Action () -> Action () | ||||
|   remote addrs action = liftF $ Remote addrs action () | ||||
|  | ||||
|   fetchRepository :: Action () | ||||
|   fetchRepository = liftF $ FetchRepository () | ||||
|   | ||||
							
								
								
									
										64
									
								
								src/System/Serverman/Actions/Call.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										64
									
								
								src/System/Serverman/Actions/Call.hs
									
									
									
									
									
										Normal file
									
								
							| @@ -0,0 +1,64 @@ | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
| {-# LANGUAGE ScopedTypeVariables #-} | ||||
|  | ||||
| module System.Serverman.Actions.Call (callService) where | ||||
|   import System.Serverman.Types | ||||
|   import System.Serverman.Utils | ||||
|   import qualified System.Serverman.Actions.Repository | ||||
|  | ||||
|   import System.Directory | ||||
|   import System.FilePath | ||||
|   import Language.Haskell.Interpreter hiding (get, name) | ||||
|   import Control.Monad.State | ||||
|   import System.Posix.Env | ||||
|   import Data.List | ||||
|   import Stack.Package | ||||
|  | ||||
|   callService :: Service -> Params -> App () | ||||
|   callService s@(Service { name, version }) params = 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" | ||||
|  | ||||
|     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] | ||||
|         includeArgs = map ("-i"++) include | ||||
|  | ||||
|     (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 | ||||
|       Left err -> liftIO $ do | ||||
|         putStrLn $ "error reading `call` from module " ++ entry | ||||
|         print err | ||||
|  | ||||
|     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 path entry = do | ||||
|     set [searchPath := path] | ||||
|     loadModules [entry] | ||||
|     setTopLevelModules ["Main"] | ||||
|     interpret "call" (as :: App ()) | ||||
|  | ||||
| @@ -1,13 +1,13 @@ | ||||
| module System.Serverman.Actions.Env (OS(..), getOS) where | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Types | ||||
|  | ||||
|   import System.Process | ||||
|   import Data.List | ||||
|   import System.IO.Error | ||||
|   import Data.Either | ||||
|   import Data.Char | ||||
|    | ||||
|   data OS = Debian | Arch | Mac | Unknown deriving (Show, Eq) | ||||
|    | ||||
|   getOS = do | ||||
|     arch_release <- execute "cat" ["/etc/os-release"] "" False | ||||
|     deb_release <- execute "cat" ["/etc/lsb-release"] "" False | ||||
|   | ||||
| @@ -17,7 +17,7 @@ module System.Serverman.Actions.FileSharing (FileSharingParams(..)) where | ||||
|  | ||||
|   instance Show FileSharingParams where | ||||
|     show (FileSharingParams { fDirectory, fUser, fPass, fPort, fWritable, fAnonymous, fAnonymousWrite, fService }) | ||||
|       | fService == VsFTPd =  | ||||
|       | name fService == "vsftpd" =  | ||||
|           let boolToEnglish True  = "YES" | ||||
|               boolToEnglish False = "NO" | ||||
|           in  | ||||
|   | ||||
| @@ -1,11 +1,12 @@ | ||||
| {-# LANGUAGE FlexibleContexts #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
|  | ||||
| module System.Serverman.Actions.Install (installService, package, dependencies) where | ||||
| module System.Serverman.Actions.Install (installService) where | ||||
|   import System.Serverman.Action | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Services | ||||
|   import System.Serverman.Actions.Env | ||||
|  | ||||
|   import System.Serverman.Types | ||||
|  | ||||
|   import System.IO.Error | ||||
|   import System.Process | ||||
| @@ -14,45 +15,24 @@ module System.Serverman.Actions.Install (installService, package, dependencies) | ||||
|   import Control.Monad.State | ||||
|   import Control.Monad.Trans.Control | ||||
|  | ||||
|   class Installable a where | ||||
|     dependencies :: a -> [a] | ||||
|     package :: a -> OS -> String | ||||
|  | ||||
|   instance Installable Service where | ||||
|     dependencies NGINX = [LetsEncrypt] | ||||
|     dependencies _ = [] | ||||
|  | ||||
|     package LetsEncrypt Arch = "certbot" | ||||
|     package LetsEncrypt _ = "letsencrypt" | ||||
|  | ||||
|     package NGINX _ = "nginx" | ||||
|  | ||||
|     package MySQL _ = "mysql" | ||||
|  | ||||
|     package MongoDB _ = "mongodb" | ||||
|  | ||||
|     package VsFTPd _ = "vsftpd" | ||||
|  | ||||
|     package SSHFs _ = "sshfs" | ||||
|  | ||||
|   installService :: Service -> OS -> App () | ||||
|   installService service os = do | ||||
|     forM_ (dependencies service) (`installService` os)  | ||||
|   installService s@(Service { dependencies, packages }) os = do | ||||
|     forM_ dependencies (`installService` os)  | ||||
|  | ||||
|     let base = case os of | ||||
|           Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"]) | ||||
|           Debian -> ("apt-get", ["install", "-y"]) | ||||
|           Mac -> ("brew", ["install", "-y"]) | ||||
|           _ -> ("echo", ["Unknown operating system"]) | ||||
|         pkg = package service os | ||||
|         pkg = packageByOS s os | ||||
|  | ||||
|     process <- liftedAsync $ do | ||||
|       result <- executeRoot (fst base) (snd base ++ [pkg]) "" True | ||||
|       result <- executeRoot (fst base) (snd base ++ pkg) "" True | ||||
|  | ||||
|       case result of | ||||
|         Left err -> return () | ||||
|         Right _ -> do | ||||
|           liftIO $ putStrLn $ "installed " ++ show service ++ "." | ||||
|           liftIO $ putStrLn $ "installed " ++ show s ++ "." | ||||
|        | ||||
|     liftIO $ wait process | ||||
|     return () | ||||
|   | ||||
							
								
								
									
										22
									
								
								src/System/Serverman/Actions/Manage.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										22
									
								
								src/System/Serverman/Actions/Manage.hs
									
									
									
									
									
										Normal file
									
								
							| @@ -0,0 +1,22 @@ | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
|  | ||||
| module System.Serverman.Actions.Manage (startService, stopService) where | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Actions.Env | ||||
|   import System.Serverman.Actions.Install | ||||
|   import System.Serverman.Services | ||||
|  | ||||
|   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 () | ||||
|  | ||||
|   stopService :: Service -> OS -> App () | ||||
|   stopService (Service { service }) os | ||||
|     | os == Mac = liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically." | ||||
|     | otherwise = executeRoot "systemctl" ["stop", service] "" True | ||||
|                 >> return () | ||||
| @@ -21,8 +21,8 @@ module System.Serverman.Actions.Nginx (nginx) where | ||||
|     do | ||||
|       -- Turn SSL off at first, because we have not yet received a certificate | ||||
|       let content = show (params { ssl = False, port = "80" }) | ||||
|           mainConfig = configDirectory serverService </> "nginx.conf" | ||||
|           parent = configDirectory serverService </> "serverman-configs" | ||||
|           mainConfig = config serverService </> "nginx.conf" | ||||
|           parent = config serverService </> "serverman-configs" | ||||
|           path = parent </> domain | ||||
|           targetDir = wDirectory | ||||
|  | ||||
| @@ -33,7 +33,7 @@ module System.Serverman.Actions.Nginx (nginx) where | ||||
|         writeIncludeStatementIfMissing mainConfig parent | ||||
|  | ||||
|         when ssl $ do | ||||
|           let sslPath = configDirectory serverService </> "ssl.conf" | ||||
|           let sslPath = config serverService </> "ssl.conf" | ||||
|           writeFileIfMissing sslPath nginxSSL | ||||
|           putStrLn $ "wrote ssl configuration to " ++ sslPath | ||||
|  | ||||
|   | ||||
| @@ -14,8 +14,6 @@ module System.Serverman.Actions.Remote ( runRemotely | ||||
|   import Data.IORef | ||||
|   import Control.Monad.State | ||||
|  | ||||
|   import Debug.Trace | ||||
|  | ||||
|   runRemotely :: Address -> App r -> App () | ||||
|   runRemotely addr@(Address host port user) action = do | ||||
|     let servermanAddr = Address host port "serverman" | ||||
|   | ||||
							
								
								
									
										86
									
								
								src/System/Serverman/Actions/Repository.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										86
									
								
								src/System/Serverman/Actions/Repository.hs
									
									
									
									
									
										Normal file
									
								
							| @@ -0,0 +1,86 @@ | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE ScopedTypeVariables #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
|  | ||||
| module System.Serverman.Actions.Repository (fetchRepo) where | ||||
|   import System.Serverman.Utils | ||||
|   import System.Directory | ||||
|   import System.Serverman.Services | ||||
|   import System.Serverman.Actions.Env | ||||
|   import System.Serverman.Types | ||||
|  | ||||
|   import System.FilePath | ||||
|   import Data.Maybe | ||||
|   import Data.Either | ||||
|   import Data.Aeson | ||||
|   import Data.Aeson.Types | ||||
|   import GHC.Generics | ||||
|   import qualified Data.Map as M | ||||
|   import Control.Monad.State | ||||
|   import qualified Data.ByteString.Lazy.Char8 as BS | ||||
|   import qualified Data.Text as T | ||||
|  | ||||
|   sourceURL = "https://github.com/mdibaiee/serverman" | ||||
|  | ||||
|   fetchRepo :: App Repository | ||||
|   fetchRepo = do | ||||
|     state@(AppState { repositoryURL }) <- get | ||||
|     dir <- liftIO $ getAppUserDataDirectory "serverman" | ||||
|     let path = dir </> "repository" | ||||
|     let source = dir </> "source" | ||||
|  | ||||
|     execIfMissing path $ do | ||||
|       liftIO $ putStrLn $ "cloning " ++ repositoryURL ++ " in " ++ path | ||||
|       execute "git" ["clone", repositoryURL, path] "" True | ||||
|       return () | ||||
|  | ||||
|     execIfMissing source $ do | ||||
|       liftIO $ putStrLn $ "cloning " ++ sourceURL ++ " in " ++ source | ||||
|       execute "git" ["clone", sourceURL, source] "" True | ||||
|       return () | ||||
|  | ||||
|     {-exec "git" ["pull", "origin", "master"] "" (Just path) True-} | ||||
|     {-exec "git" ["pull", "origin", "master"] "" (Just source) True-} | ||||
|  | ||||
|     content <- liftIO $ readFile (path </> "repository.json") | ||||
|  | ||||
|     let json = decode (BS.pack content) :: Maybe [Object] | ||||
|  | ||||
|     case json of | ||||
|       Just d -> do | ||||
|         let repo :: Maybe [Either String Service] = mapM toService d | ||||
|  | ||||
|         case repo of | ||||
|           Just list -> do | ||||
|             let r = rights list | ||||
|             state <- get | ||||
|             put $ state { repository = r } | ||||
|             return $ rights list | ||||
|  | ||||
|           Nothing -> do | ||||
|             liftIO $ putStrLn $ "error parsing repository data, please try re-fetching the repository." | ||||
|             return [] | ||||
|       Nothing -> do | ||||
|         liftIO $ putStrLn $ "error parsing repository data, please try re-fetching the repository." | ||||
|         return [] | ||||
|  | ||||
|     where | ||||
|       toService obj = do | ||||
|         return $ | ||||
|           flip parseEither obj $ \object -> do | ||||
|             name <- object .: "name" | ||||
|             version <- object .: "version" | ||||
|             config <- object .: "config" | ||||
|             service <- object .: "service" | ||||
|             category <- object .: "category" | ||||
|             packages <- object .: "packages" | ||||
|  | ||||
|             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 | ||||
|                            } | ||||
| @@ -1,4 +1,6 @@ | ||||
| module System.Serverman.Actions.Start (startService) where | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
|  | ||||
| module System.Serverman.Actions.Manage (startService, stopService) where | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Actions.Env | ||||
|   import System.Serverman.Actions.Install | ||||
| @@ -7,8 +9,14 @@ module System.Serverman.Actions.Start (startService) where | ||||
|   import Control.Monad.State | ||||
|  | ||||
|   startService :: Service -> OS -> App () | ||||
|   startService service os | ||||
|     | os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ package service os ++ " automatically. If you encounter any problems, make sure it is running." | ||||
|     | otherwise = executeRoot "systemctl" ["start", package service os] "" True | ||||
|   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 () | ||||
|  | ||||
|   stopService :: Service -> OS -> App () | ||||
|   stopService (Service { service }) os | ||||
|     | os == Mac = liftIO $ putStrLn $ "Couldn't stop " ++ service ++ " automatically." | ||||
|     | otherwise = executeRoot "systemctl" ["stop", service] "" True | ||||
|                 >> return () | ||||
|   | ||||
| @@ -21,7 +21,7 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where | ||||
|   vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) = | ||||
|     do | ||||
|       let content = show params | ||||
|           original = configDirectory fService | ||||
|           original = config fService | ||||
|           userList = takeDirectory original </> "vsftpd-serverman-user-list" | ||||
|  | ||||
|       when fRecreateUser $ executeRoot "userdel" [fUser] "" True >> return () | ||||
|   | ||||
| @@ -18,7 +18,7 @@ module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) whe | ||||
|                                    } deriving (Eq) | ||||
|   instance Show ServerParams where | ||||
|     show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService })  | ||||
|       | serverService == NGINX =  | ||||
|       | name serverService == "nginx" =  | ||||
|           let redirect | ||||
|                 | ssl = block "server" $ | ||||
|                               semicolon $ | ||||
|   | ||||
							
								
								
									
										18
									
								
								src/System/Serverman/App.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										18
									
								
								src/System/Serverman/App.hs
									
									
									
									
									
										Normal file
									
								
							| @@ -0,0 +1,18 @@ | ||||
| module System.Serverman.App ( AppState (..) | ||||
|                             , App | ||||
|                             , runApp) where | ||||
|  | ||||
|   import qualified System.Serverman.Services (Repository) | ||||
|  | ||||
|   data AppState rep = AppState { remoteMode :: Maybe (Address, String) | ||||
|                                 , repository :: Repository | ||||
|                                 } deriving (Show) | ||||
|  | ||||
|   instance Default AppState where | ||||
|     def = AppState { remoteMode = Nothing | ||||
|                    , repository = [] } | ||||
|   type App = StateT AppState IO | ||||
|  | ||||
|   runApp :: App a -> IO (a, AppState) | ||||
|   runApp k = runStateT k def | ||||
|  | ||||
| @@ -1,28 +1,27 @@ | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
| {-# LANGUAGE DeriveGeneric #-} | ||||
|  | ||||
| module System.Serverman.Services ( Service(..) | ||||
|                                  , configDirectory) where | ||||
|                                  , Repository | ||||
|                                  , packageByOS | ||||
|                                  , info) where | ||||
|   import System.Serverman.Utils | ||||
|   import System.Serverman.Actions.Env | ||||
|   import System.Serverman.Types | ||||
|  | ||||
|   data Service = NGINX | ||||
|                | MySQL | ||||
|                | MongoDB | ||||
|                | VsFTPd | ||||
|                | LetsEncrypt | ||||
|                | SSHFs | ||||
|                  deriving (Eq, Show) | ||||
|   import Data.Aeson | ||||
|   import Data.Maybe | ||||
|   import GHC.Generics | ||||
|  | ||||
|   class Configurable a where | ||||
|     configDirectory :: a -> FilePath | ||||
|   packageByOS :: Service -> OS -> [String] | ||||
|   packageByOS (Service { packages }) os = fromMaybe (fromJust $ lookup Unknown packages) (lookup os packages) | ||||
|  | ||||
|   instance Configurable Service where | ||||
|     configDirectory NGINX = "/etc/nginx/" | ||||
|     configDirectory MySQL = "/etc/mysql/" | ||||
|     configDirectory MongoDB = "/etc/mongodb" | ||||
|     configDirectory VsFTPd = "/etc/vsftpd.conf" | ||||
|  | ||||
|   instance Read Service where | ||||
|     readsPrec _ service | ||||
|           | service == "nginx" = [(NGINX, [])] | ||||
|           | service == "mysql" = [(MySQL, [])] | ||||
|           | service == "mongodb" = [(MongoDB, [])] | ||||
|           | service == "vsftpd" = [(VsFTPd, [])] | ||||
|           | service == "letsencrypt" = [(LetsEncrypt, [])] | ||||
|           | service == "sshfs" = [(SSHFs, [])] | ||||
|   info :: Service -> String | ||||
|   info s@(Service { config, packages, service, version, dependencies }) =  | ||||
|     show s ++ ( | ||||
|       indent $ | ||||
|         keyvalue [ ("config", config) | ||||
|                  , ("pacakges", commas $ map (commas . snd) packages) | ||||
|                  , ("service", service) | ||||
|                  , ("dependencies", commas $ map name dependencies)] ": " | ||||
|     ) | ||||
|   | ||||
							
								
								
									
										91
									
								
								src/System/Serverman/Types.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										91
									
								
								src/System/Serverman/Types.hs
									
									
									
									
									
										Normal file
									
								
							| @@ -0,0 +1,91 @@ | ||||
| {-# LANGUAGE DeriveGeneric #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
|  | ||||
| module System.Serverman.Types ( Service (..) | ||||
|                               , Repository | ||||
|                               , AppState (..) | ||||
|                               , OS (..) | ||||
|                               , App | ||||
|                               , Address (..) | ||||
|                               , Params | ||||
|                               , runApp) where | ||||
|   import Data.Default.Class | ||||
|   import GHC.Generics | ||||
|   import Control.Monad.State | ||||
|  | ||||
|   type Host = String | ||||
|   type Port = String | ||||
|   type User = String | ||||
|   data Address = Address Host Port User  | ||||
|  | ||||
|   type Params = [(String, String)] | ||||
|  | ||||
|   instance Read Address where | ||||
|     readsPrec _ addr | ||||
|       | '@' `elem` addr = | ||||
|             let (user, rest) = (takeWhile (/= '@') addr, tail $ dropWhile (/= '@') addr) | ||||
|                 (host, port) = readHostPort rest | ||||
|             in [(Address host port user, [])] | ||||
|       | otherwise =  | ||||
|             let (host, port) = readHostPort addr | ||||
|             in [(Address host port "", [])] | ||||
|  | ||||
|       where | ||||
|         readHostPort str = (takeWhile (/= ':') str, tail $ dropWhile (/= ':') str) | ||||
|  | ||||
|   instance Show Address where | ||||
|     show (Address host port user) | ||||
|       | (not . null) user = user ++ "@" ++ show (Address host port "") | ||||
|       | (not . null) port = show (Address host "" "") ++ ":" ++ port | ||||
|       | otherwise = host | ||||
|  | ||||
|  | ||||
|   data OS = Debian | Arch | Mac | Unknown deriving (Eq) | ||||
|  | ||||
|   instance Read OS where | ||||
|     readsPrec _ os | ||||
|       | os == "debian" = [(Debian, [])] | ||||
|       | os == "arch" = [(Arch, [])] | ||||
|       | os == "mac" = [(Mac, [])] | ||||
|       | os == "_" = [(Unknown, [])] | ||||
|  | ||||
|   instance Show OS where | ||||
|     show os | ||||
|       | os == Debian = "debian" | ||||
|       | os == Arch = "arch" | ||||
|       | os == Mac = "mac" | ||||
|       | os == Unknown = "_" | ||||
|  | ||||
|   data Service = Service { name         :: String | ||||
|                          , config       :: String | ||||
|                          , packages     :: [(OS, [String])] | ||||
|                          , service      :: String | ||||
|                          , version      :: String | ||||
|                          , dependencies :: [Service] | ||||
|                          , category     :: String | ||||
|                          } deriving (Eq, Generic) | ||||
|  | ||||
|   instance Read Service where | ||||
|     readsPrec _ service = [(Service { name = service }, [])] | ||||
|  | ||||
|   instance Show Service where | ||||
|     show (Service { name, version }) = | ||||
|       name ++ "@" ++ version | ||||
|  | ||||
|   type Repository = [Service] | ||||
|  | ||||
|   data AppState = AppState { remoteMode :: Maybe (Address, String) | ||||
|                            , repository :: Repository | ||||
|                            , repositoryURL :: String | ||||
|                            } deriving (Show) | ||||
|  | ||||
|   instance Default AppState where | ||||
|     def = AppState { remoteMode = Nothing | ||||
|                    , repository = def | ||||
|                    , repositoryURL = "https://github.com/mdibaiee/serverman-repository" | ||||
|                    } | ||||
|   type App = StateT AppState IO | ||||
|  | ||||
|   runApp :: App a -> IO (a, AppState) | ||||
|   runApp k = runStateT k def | ||||
|  | ||||
| @@ -6,9 +6,11 @@ module System.Serverman.Utils ( App (..) | ||||
|                               , runApp | ||||
|                               , keyvalue | ||||
|                               , parseKeyValue | ||||
|                               , splitAtElem | ||||
|                               , semicolon | ||||
|                               , block | ||||
|                               , indent | ||||
|                               , commas | ||||
|                               , quote | ||||
|                               , removeTrailingNewline | ||||
|                               , execIfMissing | ||||
| @@ -44,16 +46,7 @@ module System.Serverman.Utils ( App (..) | ||||
|   import Control.Monad.Trans.Control | ||||
|   import Data.Default.Class | ||||
|  | ||||
|   import Debug.Trace | ||||
|  | ||||
|   data AppState = AppState { remoteMode :: Maybe (Address, String) } deriving (Show) | ||||
|  | ||||
|   instance Default AppState where | ||||
|     def = AppState { remoteMode = Nothing } | ||||
|   type App = StateT AppState IO | ||||
|  | ||||
|   runApp :: App a -> IO (a, AppState) | ||||
|   runApp k = runStateT k def | ||||
|   import System.Serverman.Types | ||||
|  | ||||
|   keyvalue :: [(String, String)] -> String -> String | ||||
|   keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit | ||||
| @@ -67,15 +60,29 @@ module System.Serverman.Utils ( App (..) | ||||
|             (key, value) = splitAt delimitIndex line | ||||
|         in (key, tail value) | ||||
|  | ||||
|   splitAtElem :: String -> Char -> [String] | ||||
|   splitAtElem "" _ = [] | ||||
|   splitAtElem str char = | ||||
|     case charIndex of | ||||
|       Just index ->  | ||||
|         let (left, x:right) = splitAt index str | ||||
|         in left : splitAtElem right char | ||||
|       Nothing -> [str] | ||||
|     where | ||||
|       charIndex = char `elemIndex` str | ||||
|  | ||||
|   semicolon :: String -> String | ||||
|   semicolon text = unlines $ map (++ ";") (lines text) | ||||
|  | ||||
|   block :: String -> String -> String | ||||
|   block blockName content = blockName ++ " {\n" ++ indent content ++ "}" | ||||
|  | ||||
|   commas :: [String] -> String | ||||
|   commas text = intercalate ", " text | ||||
|  | ||||
|   execIfMissing :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f () | ||||
|   execIfMissing path action = do | ||||
|     exists <- liftIO $ doesFileExist path | ||||
|     exists <- liftIO $ doesPathExist path | ||||
|      | ||||
|     when (not exists) action | ||||
|  | ||||
| @@ -148,30 +155,6 @@ module System.Serverman.Utils ( App (..) | ||||
|         where | ||||
|           specialCharacters = ["$"] | ||||
|  | ||||
|   type Host = String | ||||
|   type Port = String | ||||
|   type User = String | ||||
|   data Address = Address Host Port User  | ||||
|  | ||||
|   instance Read Address where | ||||
|     readsPrec _ addr | ||||
|       | '@' `elem` addr = | ||||
|             let (user, rest) = (takeWhile (/= '@') addr, tail $ dropWhile (/= '@') addr) | ||||
|                 (host, port) = readHostPort rest | ||||
|             in [(Address host port user, [])] | ||||
|       | otherwise =  | ||||
|             let (host, port) = readHostPort addr | ||||
|             in [(Address host port "", [])] | ||||
|  | ||||
|       where | ||||
|         readHostPort str = (takeWhile (/= ':') str, tail $ dropWhile (/= ':') str) | ||||
|  | ||||
|   instance Show Address where | ||||
|     show (Address host port user) | ||||
|       | (not . null) user = user ++ "@" ++ show (Address host port "") | ||||
|       | (not . null) port = show (Address host "" "") ++ ":" ++ port | ||||
|       | otherwise = host | ||||
|  | ||||
|   execRemote :: Address -> Maybe String -> Maybe String -> String -> String -> [String] -> String -> Maybe String -> Bool -> App (Either String String) | ||||
|   execRemote addr@(Address host port user) maybeKey maybeUser password cmd args stdin cwd logErrors = do | ||||
|     let userArgument = if isJust maybeUser then ["echo", password, "|", "sudo -S", "-u", fromJust maybeUser] else [] | ||||
|   | ||||
| @@ -1,12 +1,10 @@ | ||||
| {-# LANGUAGE DeriveDataTypeable #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
| {-# LANGUAGE ScopedTypeVariables #-} | ||||
|  | ||||
| module System.Term ( initialize ) where | ||||
|   import System.Serverman.Services | ||||
|   import qualified System.Serverman as S | ||||
|  | ||||
|   import System.Console.CmdArgs | ||||
|   import qualified System.Console.CmdArgs.Explicit as E | ||||
|   import System.Environment | ||||
|   import System.Directory | ||||
|   import System.Exit | ||||
| @@ -14,199 +12,229 @@ module System.Term ( initialize ) where | ||||
|   import Data.Maybe | ||||
|   import Control.Monad | ||||
|   import Control.Monad.State | ||||
|   import Data.Default.Class | ||||
|   import System.FilePath | ||||
|   import Data.List | ||||
|  | ||||
|   import System.Serverman.Utils | ||||
|  | ||||
|   initialize = do | ||||
|     args <- getArgs | ||||
|     let mode = cmdArgsMode $ modes [install, webserver, database, filesharing]  | ||||
|                            &= program "serverman" | ||||
|                            &= summary "serverman v0.1.0, (C) Mahdi Dibaiee 2017" | ||||
|                            &= helpArg [name "h"] | ||||
|  | ||||
|     user <- getEnv "USER" | ||||
|     dir <- liftIO $ getAppUserDataDirectory "serverman" | ||||
|     let path = dir </> "repository" | ||||
|  | ||||
|     {-when (user == "ROOT") $ do-} | ||||
|       {-putStrLn $ "It's recommended that you don't run serverman as root."-} | ||||
|       {-putStrLn $ "Serverman will automatically use sudo whenever needed."-} | ||||
|     liftIO $ print args | ||||
|     let params = parseParams args | ||||
|     liftIO $ print params | ||||
|  | ||||
|     let fixArgs | ||||
|                   | null args = ["--help"] | ||||
|                   | otherwise = args | ||||
|     -- Fetch repository first | ||||
|     S.runApp $ do | ||||
|       S.run (S.fetchRepository) | ||||
|  | ||||
|     let result = E.process mode fixArgs | ||||
|       state@(S.AppState { S.repository }) <- get | ||||
|  | ||||
|     case result of  | ||||
|       Right (CmdArgs args help version _ _) ->  | ||||
|         if isJust help then | ||||
|           putStrLn $ fromJust help | ||||
|         else if isJust version then | ||||
|           putStrLn $ fromJust version | ||||
|         else | ||||
|           case args of | ||||
|             p@(WebServerParams {})   -> webserverSetup p | ||||
|             p@(InstallParams {})     -> manualInstall p | ||||
|             p@(DatabaseParams {})    -> databaseSetup p | ||||
|             p@(FileSharingParams {}) -> fileSharingSetup p | ||||
|       Left err -> | ||||
|         print err | ||||
|       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) | ||||
|  | ||||
|       {-S.run (S.call (head repository) [])-} | ||||
|  | ||||
|     return () | ||||
|  | ||||
|   -- WEB SERVER  | ||||
|   data Params = WebServerParams { directory :: String | ||||
|                                 , domain    :: String | ||||
|                                 , port      :: String | ||||
|                                 , forward   :: String | ||||
|                                 , wService  :: String | ||||
|                                 , ssl       :: Bool | ||||
|                                 , email     :: String | ||||
|                                 , wRemote   :: String | ||||
|                                 } | ||||
|               | DatabaseParams { databaseName :: String | ||||
|                                , dService     :: String | ||||
|                                , dummyData    :: Bool | ||||
|                                , dUser        :: String | ||||
|                                , dPass        :: String | ||||
|                                , dHost        :: String | ||||
|                                , dRemote      :: String | ||||
|                                } | ||||
|  | ||||
|               | FileSharingParams { fDirectory      :: String | ||||
|                                   , fUser           :: String | ||||
|                                   , fPass           :: String | ||||
|                                   , fPort           :: String | ||||
|                                   , fWritable       :: Bool | ||||
|                                   , fAnonymous      :: Bool | ||||
|                                   , fAnonymousWrite :: Bool | ||||
|                                   , fRecreateUser   :: Bool | ||||
|                                   , fService        :: String | ||||
|                                   , fRemote         :: String | ||||
|                                   } | ||||
|  | ||||
|               | InstallParams { iService :: String, remote :: String } | ||||
|  | ||||
|               deriving (Show, Data, Typeable) | ||||
|  | ||||
|   webserver = WebServerParams { 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" | ||||
|                               , wService  = "nginx" &= help "service to build config for: nginx, defaults to nginx" &= explicit &= name "service" | ||||
|                               , wRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" | ||||
|                               } &= explicit &= name "webserver" | ||||
|  | ||||
|   database = DatabaseParams { databaseName = "test" &= help "database name, defaults to test" &= explicit &= name "name" | ||||
|                             , dService     = "mysql" &= help "service to setup: mysql, defaults to mysql" &= explicit &= name "service" | ||||
|                             , dummyData    = False &= help "generate dummy data in the database" &= explicit &= name "dummy-data" | ||||
|                             , dUser        = "root" &= help "database's username, defaults to root" &= explicit &= name "user" | ||||
|                             , dPass        = "" &= help "database's password, defaults to blank string" &= explicit &= name "password" | ||||
|                             , dHost        = "127.0.0.1" &= help "database's host, defaults to localhost" &= explicit &= name "host" | ||||
|                             , dRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" | ||||
|                             } &= explicit &= name "database" | ||||
|  | ||||
|   filesharing = FileSharingParams { fDirectory      = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory" | ||||
|                                   , fUser           = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user" | ||||
|                                   , fPass           = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password" | ||||
|                                   , fAnonymous      = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous" | ||||
|                                   , fAnonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write" | ||||
|                                   , fWritable       = True &= help "allow write operations, defaults to True" &= explicit &= name "writable" | ||||
|                                   , fPort           = "21" &= help "service port, defaults to 21" &= explicit &= name "port" | ||||
|                                   , fService        = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service" | ||||
|                                   , fRecreateUser   = False &= help "recreate the user" &= explicit &= name "recreate-user" | ||||
|                                   , fRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" | ||||
|                                   } &= explicit &= name "filesharing" | ||||
|     where | ||||
|       findService repository n = fromJust $ find (\a -> S.name a == n) repository | ||||
|  | ||||
|  | ||||
|   install = InstallParams { iService = def &= argPos 0 | ||||
|                           , remote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" | ||||
|                           } &= explicit &= name "install" | ||||
|   data Manage = Start | Stop deriving (Eq, Show) | ||||
|   data Params = Params { listServices :: Bool | ||||
|                        , install      :: Maybe String | ||||
|                        , manage       :: Maybe (Manage, String) | ||||
|                        , update       :: Bool | ||||
|                        , remote       :: Maybe FilePath | ||||
|                        , help         :: Bool | ||||
|                        } deriving (Show) | ||||
|  | ||||
|   webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email, wRemote }) = do | ||||
|     remoteSetup wRemote $ do | ||||
|       when (ssl && null email) $ die "Email is required for generating a certificate" | ||||
|   instance Default Params where | ||||
|     def = Params { listServices = False | ||||
|                   , install      = Nothing | ||||
|                   , manage       = Nothing | ||||
|                   , remote       = Nothing | ||||
|                   , update       = False | ||||
|                   , help         = False | ||||
|                   } | ||||
|  | ||||
|       let serverType  | ||||
|             | (not . null) forward = S.PortForwarding | ||||
|             | otherwise = S.Static | ||||
|   parseParams :: [String] -> Params | ||||
|   parseParams ("repository":"list":xs) = (parseParams xs) { listServices = True } | ||||
|   parseParams ("repository":"update":xs) = (parseParams xs) { update = True } | ||||
|   parseParams ("service":"start":s:xs) = (parseParams xs) { manage = Just (Start, s) } | ||||
|   parseParams ("service":"stop":s:xs) = (parseParams xs) { manage = Just (Stop, s) } | ||||
|   parseParams ("install":s:xs) = (parseParams xs) { install = Just s } | ||||
|   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 } | ||||
|  | ||||
|       let serviceName = read wService :: Service | ||||
|    {-WEB SERVER -} | ||||
|   {-data Params = WebServerParams { directory :: String-} | ||||
|                                 {-, domain    :: String-} | ||||
|                                 {-, port      :: String-} | ||||
|                                 {-, forward   :: String-} | ||||
|                                 {-, wService  :: String-} | ||||
|                                 {-, ssl       :: Bool-} | ||||
|                                 {-, email     :: String-} | ||||
|                                 {-, wRemote   :: String-} | ||||
|                                 {-}-} | ||||
|               {-| DatabaseParams { databaseName :: String-} | ||||
|                                {-, dService     :: String-} | ||||
|                                {-, dummyData    :: Bool-} | ||||
|                                {-, dUser        :: String-} | ||||
|                                {-, dPass        :: String-} | ||||
|                                {-, dHost        :: String-} | ||||
|                                {-, dRemote      :: String-} | ||||
|                                {-}-} | ||||
|  | ||||
|       let portNumber | ||||
|             | (not . null) port = port | ||||
|             | ssl = "443" | ||||
|             | otherwise = "80" | ||||
|               {-| FileSharingParams { fDirectory      :: String-} | ||||
|                                   {-, fUser           :: String-} | ||||
|                                   {-, fPass           :: String-} | ||||
|                                   {-, fPort           :: String-} | ||||
|                                   {-, fWritable       :: Bool-} | ||||
|                                   {-, fAnonymous      :: Bool-} | ||||
|                                   {-, fAnonymousWrite :: Bool-} | ||||
|                                   {-, fRecreateUser   :: Bool-} | ||||
|                                   {-, fService        :: String-} | ||||
|                                   {-, fRemote         :: String-} | ||||
|                                   {-}-} | ||||
|  | ||||
|       absoluteDirectory <- makeAbsolute directory | ||||
|               {-| InstallParams { iService :: String, remote :: String }-} | ||||
|  | ||||
|       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 | ||||
|               {-deriving (Show, Data, Typeable)-} | ||||
|  | ||||
|   manualInstall (InstallParams { iService, remote }) = | ||||
|     remoteSetup remote $ do | ||||
|       let serviceName = read iService :: Service | ||||
|   {-webserver = WebServerParams { 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"-} | ||||
|                               {-, wService  = "nginx" &= help "service to build config for: nginx, defaults to nginx" &= explicit &= name "service"-} | ||||
|                               {-, wRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"-} | ||||
|                               {-} &= explicit &= name "webserver"-} | ||||
|  | ||||
|       return $ S.detectOS >>= (S.install serviceName) | ||||
|              >> S.detectOS >>= (S.start serviceName) | ||||
|   {-database = DatabaseParams { databaseName = "test" &= help "database name, defaults to test" &= explicit &= name "name"-} | ||||
|                             {-, dService     = "mysql" &= help "service to setup: mysql, defaults to mysql" &= explicit &= name "service"-} | ||||
|                             {-, dummyData    = False &= help "generate dummy data in the database" &= explicit &= name "dummy-data"-} | ||||
|                             {-, dUser        = "root" &= help "database's username, defaults to root" &= explicit &= name "user"-} | ||||
|                             {-, dPass        = "" &= help "database's password, defaults to blank string" &= explicit &= name "password"-} | ||||
|                             {-, dHost        = "127.0.0.1" &= help "database's host, defaults to localhost" &= explicit &= name "host"-} | ||||
|                             {-, dRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"-} | ||||
|                             {-} &= explicit &= name "database"-} | ||||
|  | ||||
|   {-filesharing = FileSharingParams { fDirectory      = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory"-} | ||||
|                                   {-, fUser           = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user"-} | ||||
|                                   {-, fPass           = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password"-} | ||||
|                                   {-, fAnonymous      = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous"-} | ||||
|                                   {-, fAnonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write"-} | ||||
|                                   {-, fWritable       = True &= help "allow write operations, defaults to True" &= explicit &= name "writable"-} | ||||
|                                   {-, fPort           = "21" &= help "service port, defaults to 21" &= explicit &= name "port"-} | ||||
|                                   {-, fService        = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service"-} | ||||
|                                   {-, fRecreateUser   = False &= help "recreate the user" &= explicit &= name "recreate-user"-} | ||||
|                                   {-, fRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"-} | ||||
|                                   {-} &= explicit &= name "filesharing"-} | ||||
|  | ||||
|  | ||||
|   databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do | ||||
|     remoteSetup dRemote $ do | ||||
|       let serviceName = read dService | ||||
|   {-install = InstallParams { iService = def &= argPos 0-} | ||||
|                           {-, remote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"-} | ||||
|                           {-} &= explicit &= name "install"-} | ||||
|  | ||||
|       let params = S.DatabaseParams { S.database        = databaseName | ||||
|                                     , S.databaseService = serviceName | ||||
|                                     , S.dummyData       = dummyData | ||||
|                                     , S.databaseUser    = dUser | ||||
|                                     , S.databasePass    = dPass | ||||
|                                     , S.databaseHost    = dHost | ||||
|                                     } | ||||
|   {-webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email, wRemote }) = do-} | ||||
|     {-remoteSetup wRemote $ do-} | ||||
|       {-when (ssl && null email) $ die "Email is required for generating a certificate"-} | ||||
|  | ||||
|       return $ S.detectOS >>= (S.install serviceName) | ||||
|             >> S.detectOS >>= (S.start serviceName) | ||||
|             >> S.newDatabase params | ||||
|       {-let serverType -} | ||||
|             {-| (not . null) forward = S.PortForwarding-} | ||||
|             {-| otherwise = S.Static-} | ||||
|  | ||||
|   fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser, fRemote }) = do | ||||
|     remoteSetup fRemote $ do | ||||
|       let serviceName = read fService | ||||
|       {-let serviceName = read wService-} | ||||
|  | ||||
|       let params = S.FileSharingParams { S.fDirectory      = fDirectory | ||||
|                                       , S.fUser           = fUser | ||||
|                                       , S.fPass           = fPass | ||||
|                                       , S.fPort           = fPort | ||||
|                                       , S.fAnonymous      = fAnonymous | ||||
|                                       , S.fAnonymousWrite = fAnonymousWrite | ||||
|                                       , S.fWritable       = fWritable | ||||
|                                       , S.fService        = serviceName | ||||
|                                       , S.fRecreateUser   = fRecreateUser | ||||
|                                       } | ||||
|       {-let portNumber-} | ||||
|             {-| (not . null) port = port-} | ||||
|             {-| ssl = "443"-} | ||||
|             {-| otherwise = "80"-} | ||||
|  | ||||
|       return $ S.detectOS >>= (S.install serviceName) | ||||
|             >> S.detectOS >>= (S.start serviceName) | ||||
|             >> S.newFileSharing params | ||||
|       {-absoluteDirectory <- makeAbsolute directory-} | ||||
|  | ||||
|   remoteSetup file generateAction | ||||
|     | null file = do | ||||
|       action <- generateAction | ||||
|       S.runApp $ | ||||
|         S.run action | ||||
|       {-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-} | ||||
|  | ||||
|       return () | ||||
|   {-manualInstall (InstallParams { iService, remote }) =-} | ||||
|     {-remoteSetup remote $ do-} | ||||
|       {-let serviceName = read iService-} | ||||
|  | ||||
|     | otherwise = do | ||||
|       list <- liftIO $ map read . lines <$> readFile file | ||||
|       action <- generateAction | ||||
|       S.runApp $ S.run $ S.remote list action | ||||
|       {-return $ S.detectOS >>= (S.install serviceName)-} | ||||
|              {->> S.detectOS >>= (S.start serviceName)-} | ||||
|      | ||||
|       return () | ||||
|  | ||||
|   {-databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do-} | ||||
|     {-remoteSetup dRemote $ do-} | ||||
|       {-let serviceName = read dService-} | ||||
|  | ||||
|       {-let params = S.DatabaseParams { S.database        = databaseName-} | ||||
|                                     {-, S.databaseService = serviceName-} | ||||
|                                     {-, S.dummyData       = dummyData-} | ||||
|                                     {-, S.databaseUser    = dUser-} | ||||
|                                     {-, S.databasePass    = dPass-} | ||||
|                                     {-, S.databaseHost    = dHost-} | ||||
|                                     {-}-} | ||||
|  | ||||
|       {-return $ S.detectOS >>= (S.install serviceName)-} | ||||
|             {->> S.detectOS >>= (S.start serviceName)-} | ||||
|             {->> S.newDatabase params-} | ||||
|  | ||||
|   {-fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser, fRemote }) = do-} | ||||
|     {-remoteSetup fRemote $ do-} | ||||
|       {-let serviceName = read fService-} | ||||
|  | ||||
|       {-let params = S.FileSharingParams { S.fDirectory      = fDirectory-} | ||||
|                                       {-, S.fUser           = fUser-} | ||||
|                                       {-, S.fPass           = fPass-} | ||||
|                                       {-, S.fPort           = fPort-} | ||||
|                                       {-, S.fAnonymous      = fAnonymous-} | ||||
|                                       {-, S.fAnonymousWrite = fAnonymousWrite-} | ||||
|                                       {-, S.fWritable       = fWritable-} | ||||
|                                       {-, S.fService        = serviceName-} | ||||
|                                       {-, S.fRecreateUser   = fRecreateUser-} | ||||
|                                       {-}-} | ||||
|  | ||||
|       {-return $ S.detectOS >>= (S.install serviceName)-} | ||||
|             {->> S.detectOS >>= (S.start serviceName)-} | ||||
|             {->> S.newFileSharing params-} | ||||
|  | ||||
|   {-remoteSetup file generateAction-} | ||||
|     {-| null file = do-} | ||||
|       {-action <- generateAction-} | ||||
|       {-S.runApp $-} | ||||
|         {-S.run action-} | ||||
|  | ||||
|       {-return ()-} | ||||
|  | ||||
|     {-| otherwise = do-} | ||||
|       {-list <- liftIO $ map read . lines <$> readFile file-} | ||||
|       {-action <- generateAction-} | ||||
|       {-S.runApp $ S.run $ S.remote list action-} | ||||
|  | ||||
|       {-return ()-} | ||||
|   | ||||
|   | ||||
							
								
								
									
										72
									
								
								stack.yaml
									
									
									
									
									
								
							
							
						
						
									
										72
									
								
								stack.yaml
									
									
									
									
									
								
							| @@ -1,66 +1,10 @@ | ||||
| # This file was automatically generated by 'stack init' | ||||
| # | ||||
| # Some commonly used options have been documented as comments in this file. | ||||
| # For advanced use and comprehensive documentation of the format, please see: | ||||
| # http://docs.haskellstack.org/en/stable/yaml_configuration/ | ||||
|  | ||||
| # Resolver to choose a 'specific' stackage snapshot or a compiler version. | ||||
| # A snapshot resolver dictates the compiler version and the set of packages | ||||
| # to be used for project dependencies. For example: | ||||
| # | ||||
| # resolver: lts-3.5 | ||||
| # resolver: nightly-2015-09-21 | ||||
| # resolver: ghc-7.10.2 | ||||
| # resolver: ghcjs-0.1.0_ghc-7.10.2 | ||||
| # resolver: | ||||
| #  name: custom-snapshot | ||||
| #  location: "./custom-snapshot.yaml" | ||||
| resolver: lts-8.0 | ||||
|  | ||||
| # User packages to be built. | ||||
| # Various formats can be used as shown in the example below. | ||||
| # | ||||
| # packages: | ||||
| # - some-directory | ||||
| # - https://example.com/foo/bar/baz-0.0.2.tar.gz | ||||
| # - location: | ||||
| #    git: https://github.com/commercialhaskell/stack.git | ||||
| #    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a | ||||
| # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a | ||||
| #   extra-dep: true | ||||
| #  subdirs: | ||||
| #  - auto-update | ||||
| #  - wai | ||||
| # | ||||
| # A package marked 'extra-dep: true' will only be built if demanded by a | ||||
| # non-dependency (i.e. a user package), and its test suites and benchmarks | ||||
| # will not be run. This is useful for tweaking upstream packages. | ||||
| flags: {} | ||||
| extra-package-dbs: [] | ||||
| packages: | ||||
| - '.' | ||||
| # Dependency packages to be pulled from upstream that are not in the resolver | ||||
| # (e.g., acme-missiles-0.3) | ||||
| extra-deps: [] | ||||
|  | ||||
| # Override default flag values for local packages and extra-deps | ||||
| flags: {} | ||||
|  | ||||
| # Extra package databases containing global packages | ||||
| extra-package-dbs: [] | ||||
|  | ||||
| # Control whether we use the GHC we find on the path | ||||
| # system-ghc: true | ||||
| # | ||||
| # Require a specific version of stack, using version ranges | ||||
| # require-stack-version: -any # Default | ||||
| # require-stack-version: ">=1.1" | ||||
| # | ||||
| # Override the architecture used by stack, especially useful on Windows | ||||
| # arch: i386 | ||||
| # arch: x86_64 | ||||
| # | ||||
| # Extra directories used by stack for building | ||||
| # extra-include-dirs: [/path/to/dir] | ||||
| # extra-lib-dirs: [/path/to/dir] | ||||
| # | ||||
| # Allow a newer minor version of GHC than the snapshot specifies | ||||
| # compiler-check: newer-minor | ||||
| extra-deps: | ||||
| - stack-1.3.2 | ||||
| - store-0.3.1 | ||||
| - store-core-0.3 | ||||
| - th-utilities-0.2.0.1 | ||||
| resolver: lts-8.0 | ||||
|   | ||||
		Reference in New Issue
	
	Block a user