diff --git a/serverman.cabal b/serverman.cabal index 2b189bb..f7af46c 100644 --- a/serverman.cabal +++ b/serverman.cabal @@ -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 diff --git a/src/System/Serverman.hs b/src/System/Serverman.hs index e914fd5..8457973 100644 --- a/src/System/Serverman.hs +++ b/src/System/Serverman.hs @@ -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 + diff --git a/src/System/Serverman/Action.hs b/src/System/Serverman/Action.hs index aa6f08d..01f948e 100644 --- a/src/System/Serverman/Action.hs +++ b/src/System/Serverman/Action.hs @@ -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 () diff --git a/src/System/Serverman/Actions/Call.hs b/src/System/Serverman/Actions/Call.hs new file mode 100644 index 0000000..be93b3b --- /dev/null +++ b/src/System/Serverman/Actions/Call.hs @@ -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 ()) + diff --git a/src/System/Serverman/Actions/Env.hs b/src/System/Serverman/Actions/Env.hs index 43497e5..0a71c14 100644 --- a/src/System/Serverman/Actions/Env.hs +++ b/src/System/Serverman/Actions/Env.hs @@ -1,12 +1,12 @@ 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 diff --git a/src/System/Serverman/Actions/FileSharing.hs b/src/System/Serverman/Actions/FileSharing.hs index 315f8e5..38a8bc2 100644 --- a/src/System/Serverman/Actions/FileSharing.hs +++ b/src/System/Serverman/Actions/FileSharing.hs @@ -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 diff --git a/src/System/Serverman/Actions/Install.hs b/src/System/Serverman/Actions/Install.hs index 72b927d..30a1c5b 100644 --- a/src/System/Serverman/Actions/Install.hs +++ b/src/System/Serverman/Actions/Install.hs @@ -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 () diff --git a/src/System/Serverman/Actions/Manage.hs b/src/System/Serverman/Actions/Manage.hs new file mode 100644 index 0000000..35df7d9 --- /dev/null +++ b/src/System/Serverman/Actions/Manage.hs @@ -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 () diff --git a/src/System/Serverman/Actions/Nginx.hs b/src/System/Serverman/Actions/Nginx.hs index 32ee443..a861156 100644 --- a/src/System/Serverman/Actions/Nginx.hs +++ b/src/System/Serverman/Actions/Nginx.hs @@ -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 diff --git a/src/System/Serverman/Actions/Remote.hs b/src/System/Serverman/Actions/Remote.hs index 6d8f792..9b432b9 100644 --- a/src/System/Serverman/Actions/Remote.hs +++ b/src/System/Serverman/Actions/Remote.hs @@ -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" diff --git a/src/System/Serverman/Actions/Repository.hs b/src/System/Serverman/Actions/Repository.hs new file mode 100644 index 0000000..d3f1e99 --- /dev/null +++ b/src/System/Serverman/Actions/Repository.hs @@ -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 + } diff --git a/src/System/Serverman/Actions/Start.hs b/src/System/Serverman/Actions/Start.hs index d1c6274..35df7d9 100644 --- a/src/System/Serverman/Actions/Start.hs +++ b/src/System/Serverman/Actions/Start.hs @@ -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 () diff --git a/src/System/Serverman/Actions/VsFTPd.hs b/src/System/Serverman/Actions/VsFTPd.hs index 8d54844..4558b66 100644 --- a/src/System/Serverman/Actions/VsFTPd.hs +++ b/src/System/Serverman/Actions/VsFTPd.hs @@ -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 () diff --git a/src/System/Serverman/Actions/WebServer.hs b/src/System/Serverman/Actions/WebServer.hs index 66a27c3..999fd63 100644 --- a/src/System/Serverman/Actions/WebServer.hs +++ b/src/System/Serverman/Actions/WebServer.hs @@ -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 $ diff --git a/src/System/Serverman/App.hs b/src/System/Serverman/App.hs new file mode 100644 index 0000000..c2e0826 --- /dev/null +++ b/src/System/Serverman/App.hs @@ -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 + diff --git a/src/System/Serverman/Services.hs b/src/System/Serverman/Services.hs index f6d30ae..976adb2 100644 --- a/src/System/Serverman/Services.hs +++ b/src/System/Serverman/Services.hs @@ -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)] ": " + ) diff --git a/src/System/Serverman/Types.hs b/src/System/Serverman/Types.hs new file mode 100644 index 0000000..b3dd4b3 --- /dev/null +++ b/src/System/Serverman/Types.hs @@ -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 + diff --git a/src/System/Serverman/Utils.hs b/src/System/Serverman/Utils.hs index 22f010d..a1ec79f 100644 --- a/src/System/Serverman/Utils.hs +++ b/src/System/Serverman/Utils.hs @@ -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 [] diff --git a/src/System/Term.hs b/src/System/Term.hs index 37c871a..5bdeff6 100644 --- a/src/System/Term.hs +++ b/src/System/Term.hs @@ -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"-} + + + {-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"-} + + {-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"-} + + {-let serverType -} + {-| (not . null) forward = S.PortForwarding-} + {-| otherwise = S.Static-} + + {-let serviceName = read wService-} + + {-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-} + + {-manualInstall (InstallParams { iService, remote }) =-} + {-remoteSetup remote $ do-} + {-let serviceName = read iService-} + + {-return $ S.detectOS >>= (S.install serviceName)-} + {->> S.detectOS >>= (S.start serviceName)-} - databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do - remoteSetup dRemote $ do - let serviceName = read dService + {-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 - } + {-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 + {-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 + {-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 - } + {-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 + {-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 + {-remoteSetup file generateAction-} + {-| null file = do-} + {-action <- generateAction-} + {-S.runApp $-} + {-S.run action-} - return () + {-return ()-} - | otherwise = do - list <- liftIO $ map read . lines <$> readFile file - action <- generateAction - S.runApp $ S.run $ S.remote list action + {-| otherwise = do-} + {-list <- liftIO $ map read . lines <$> readFile file-} + {-action <- generateAction-} + {-S.runApp $ S.run $ S.remote list action-} - return () + {-return ()-} diff --git a/stack.yaml b/stack.yaml index 13f158a..06dca8c 100644 --- a/stack.yaml +++ b/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 \ No newline at end of file +extra-deps: +- stack-1.3.2 +- store-0.3.1 +- store-core-0.3 +- th-utilities-0.2.0.1 +resolver: lts-8.0