feat: repository

This commit is contained in:
Mahdi Dibaiee 2017-03-13 19:07:07 +03:30
parent f9d802ee71
commit cf6670bafa
20 changed files with 589 additions and 388 deletions

View File

@ -20,20 +20,14 @@ library
, System.Serverman.Utils , System.Serverman.Utils
, System.Serverman.Action , 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.Install
, System.Serverman.Actions.Env , System.Serverman.Actions.Env
, System.Serverman.Actions.Start , System.Serverman.Actions.Manage
, System.Serverman.Actions.Remote , System.Serverman.Actions.Remote
, System.Serverman.Actions.Repository
, System.Serverman.Actions.Call
, System.Serverman.Types
, System.Serverman.Services , System.Serverman.Services
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, free >= 4.12.4 && < 5 , free >= 4.12.4 && < 5
@ -52,6 +46,10 @@ library
, Unixutils , Unixutils
, mtl , mtl
, monad-control , monad-control
, aeson
, containers
, hint
, stack
default-language: Haskell2010 default-language: Haskell2010
executable serverman executable serverman

View File

@ -2,30 +2,20 @@ module System.Serverman ( run
, module System.Serverman.Action , module System.Serverman.Action
, module System.Serverman.Utils , module System.Serverman.Utils
, module System.Serverman.Services , 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.Env
, module System.Serverman.Actions.Install) where , module System.Serverman.Actions.Install) where
import System.Serverman.Action import System.Serverman.Action
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Services import System.Serverman.Services
import System.Serverman.Types
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Actions.Install 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.Remote
import System.Serverman.Actions.Call
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 Control.Monad.Free import Control.Monad.Free
@ -33,20 +23,12 @@ module System.Serverman ( run
run (Pure r) = return r run (Pure r) = return r
run (Free (DetectOS next)) = getOS >>= run . next run (Free (DetectOS next)) = getOS >>= run . next
run (Free (Start os service next)) = startService os service >> 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 (Install os service next)) = installService os service >> run next
run (Free (NewWebServer params next)) run (Free (Call service params next)) = callService service params >> run 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 (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next run (Free (Remote addrs action next)) = mapM_ (\addr -> runRemotely addr (run action)) addrs >> run next
run (Free (FetchRepository next)) = fetchRepo >> run next

View File

@ -2,20 +2,20 @@
module System.Serverman.Action ( ActionF(..) module System.Serverman.Action ( ActionF(..)
, Action , Action
, newServer , call
, newDatabase , fetchRepository
, newFileSharing
, start , start
, stop
, install , install
, remote , remote
, detectOS) where , 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.Env
import System.Serverman.Actions.Repository
import System.Serverman.Actions.Remote import System.Serverman.Actions.Remote
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Types
import System.Serverman.Services import System.Serverman.Services
import System.Directory import System.Directory
@ -28,33 +28,27 @@ module System.Serverman.Action ( ActionF(..)
import System.IO.Error import System.IO.Error
import Data.Char import Data.Char
data ActionF x = NewWebServer ServerParams x data ActionF x = Call Service Params x
| NewDatabase DatabaseParams x
| NewFileSharing FileSharingParams x
| DetectOS (OS -> x) | DetectOS (OS -> x)
| Install Service OS x | Install Service OS x
| Remote [Address] (Action ()) x | Remote [Address] (Action ()) x
| FetchRepository x
| Start Service OS x | Start Service OS x
| Stop Service OS x
instance Functor ActionF where instance Functor ActionF where
fmap f (NewWebServer params x) = NewWebServer params (f x) fmap f (Call service params x) = Call service params (f x)
fmap f (NewDatabase params x) = NewDatabase params (f x)
fmap f (NewFileSharing params x) = NewFileSharing params (f x)
fmap f (Install service os x) = Install service os (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 (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 (DetectOS x) = DetectOS (f . x)
fmap f (Remote addr action x) = Remote addr action (f x) fmap f (Remote addr action x) = Remote addr action (f x)
fmap f (FetchRepository x) = FetchRepository (f x)
type Action = Free ActionF type Action = Free ActionF
newServer :: ServerParams -> Action () call :: Service -> Params -> Action ()
newServer params = liftF $ NewWebServer params () call service params = liftF $ Call service params ()
newDatabase :: DatabaseParams -> Action ()
newDatabase params = liftF $ NewDatabase params ()
newFileSharing :: FileSharingParams -> Action ()
newFileSharing params = liftF $ NewFileSharing params ()
install :: Service -> OS -> Action () install :: Service -> OS -> Action ()
install service os = liftF $ Install service os () install service os = liftF $ Install service os ()
@ -62,8 +56,14 @@ module System.Serverman.Action ( ActionF(..)
start :: Service -> OS -> Action () start :: Service -> OS -> Action ()
start service os = liftF $ Start service os () start service os = liftF $ Start service os ()
stop :: Service -> OS -> Action ()
stop service os = liftF $ Stop service os ()
detectOS :: Action OS detectOS :: Action OS
detectOS = liftF $ DetectOS id detectOS = liftF $ DetectOS id
remote :: [Address] -> Action () -> Action () remote :: [Address] -> Action () -> Action ()
remote addrs action = liftF $ Remote addrs action () remote addrs action = liftF $ Remote addrs action ()
fetchRepository :: Action ()
fetchRepository = liftF $ FetchRepository ()

View 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 ())

View File

@ -1,13 +1,13 @@
module System.Serverman.Actions.Env (OS(..), getOS) where module System.Serverman.Actions.Env (OS(..), getOS) where
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Types
import System.Process import System.Process
import Data.List import Data.List
import System.IO.Error import System.IO.Error
import Data.Either import Data.Either
import Data.Char import Data.Char
data OS = Debian | Arch | Mac | Unknown deriving (Show, Eq)
getOS = do getOS = do
arch_release <- execute "cat" ["/etc/os-release"] "" False arch_release <- execute "cat" ["/etc/os-release"] "" False
deb_release <- execute "cat" ["/etc/lsb-release"] "" False deb_release <- execute "cat" ["/etc/lsb-release"] "" False

View File

@ -17,7 +17,7 @@ module System.Serverman.Actions.FileSharing (FileSharingParams(..)) where
instance Show FileSharingParams where instance Show FileSharingParams where
show (FileSharingParams { fDirectory, fUser, fPass, fPort, fWritable, fAnonymous, fAnonymousWrite, fService }) show (FileSharingParams { fDirectory, fUser, fPass, fPort, fWritable, fAnonymous, fAnonymousWrite, fService })
| fService == VsFTPd = | name fService == "vsftpd" =
let boolToEnglish True = "YES" let boolToEnglish True = "YES"
boolToEnglish False = "NO" boolToEnglish False = "NO"
in in

View File

@ -1,11 +1,12 @@
{-# LANGUAGE FlexibleContexts #-} {-# 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.Action
import System.Serverman.Utils import System.Serverman.Utils
import System.Serverman.Services import System.Serverman.Services
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Types
import System.IO.Error import System.IO.Error
import System.Process import System.Process
@ -14,45 +15,24 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
import Control.Monad.State import Control.Monad.State
import Control.Monad.Trans.Control 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 -> App ()
installService service os = do installService s@(Service { dependencies, packages }) os = do
forM_ (dependencies service) (`installService` os) forM_ dependencies (`installService` os)
let base = case os of let base = case os of
Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"]) Arch -> ("pacman", ["-S", "--noconfirm", "--quiet"])
Debian -> ("apt-get", ["install", "-y"]) Debian -> ("apt-get", ["install", "-y"])
Mac -> ("brew", ["install", "-y"]) Mac -> ("brew", ["install", "-y"])
_ -> ("echo", ["Unknown operating system"]) _ -> ("echo", ["Unknown operating system"])
pkg = package service os pkg = packageByOS s os
process <- liftedAsync $ do process <- liftedAsync $ do
result <- executeRoot (fst base) (snd base ++ [pkg]) "" True result <- executeRoot (fst base) (snd base ++ pkg) "" True
case result of case result of
Left err -> return () Left err -> return ()
Right _ -> do Right _ -> do
liftIO $ putStrLn $ "installed " ++ show service ++ "." liftIO $ putStrLn $ "installed " ++ show s ++ "."
liftIO $ wait process liftIO $ wait process
return () return ()

View 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 ()

View File

@ -21,8 +21,8 @@ module System.Serverman.Actions.Nginx (nginx) where
do do
-- Turn SSL off at first, because we have not yet received a certificate -- Turn SSL off at first, because we have not yet received a certificate
let content = show (params { ssl = False, port = "80" }) let content = show (params { ssl = False, port = "80" })
mainConfig = configDirectory serverService </> "nginx.conf" mainConfig = config serverService </> "nginx.conf"
parent = configDirectory serverService </> "serverman-configs" parent = config serverService </> "serverman-configs"
path = parent </> domain path = parent </> domain
targetDir = wDirectory targetDir = wDirectory
@ -33,7 +33,7 @@ module System.Serverman.Actions.Nginx (nginx) where
writeIncludeStatementIfMissing mainConfig parent writeIncludeStatementIfMissing mainConfig parent
when ssl $ do when ssl $ do
let sslPath = configDirectory serverService </> "ssl.conf" let sslPath = config serverService </> "ssl.conf"
writeFileIfMissing sslPath nginxSSL writeFileIfMissing sslPath nginxSSL
putStrLn $ "wrote ssl configuration to " ++ sslPath putStrLn $ "wrote ssl configuration to " ++ sslPath

View File

@ -14,8 +14,6 @@ module System.Serverman.Actions.Remote ( runRemotely
import Data.IORef import Data.IORef
import Control.Monad.State import Control.Monad.State
import Debug.Trace
runRemotely :: Address -> App r -> App () runRemotely :: Address -> App r -> App ()
runRemotely addr@(Address host port user) action = do runRemotely addr@(Address host port user) action = do
let servermanAddr = Address host port "serverman" let servermanAddr = Address host port "serverman"

View 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
}

View File

@ -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.Utils
import System.Serverman.Actions.Env import System.Serverman.Actions.Env
import System.Serverman.Actions.Install import System.Serverman.Actions.Install
@ -7,8 +9,14 @@ module System.Serverman.Actions.Start (startService) where
import Control.Monad.State import Control.Monad.State
startService :: Service -> OS -> App () startService :: Service -> OS -> App ()
startService service os startService (Service { service }) os
| os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ package service os ++ " automatically. If you encounter any problems, make sure it is running." | os == Mac = liftIO $ putStrLn $ "Couldn't start " ++ service ++ " automatically. If you encounter any problems, make sure it is running."
| otherwise = executeRoot "systemctl" ["start", package service os] "" True | otherwise = executeRoot "systemctl" ["start", service] "" True
>> execute "sleep" ["5s"] "" True >> execute "sleep" ["5s"] "" True
>> return () >> 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 ()

View File

@ -21,7 +21,7 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where
vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) = vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) =
do do
let content = show params let content = show params
original = configDirectory fService original = config fService
userList = takeDirectory original </> "vsftpd-serverman-user-list" userList = takeDirectory original </> "vsftpd-serverman-user-list"
when fRecreateUser $ executeRoot "userdel" [fUser] "" True >> return () when fRecreateUser $ executeRoot "userdel" [fUser] "" True >> return ()

View File

@ -18,7 +18,7 @@ module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) whe
} deriving (Eq) } deriving (Eq)
instance Show ServerParams where instance Show ServerParams where
show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService }) show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService })
| serverService == NGINX = | name serverService == "nginx" =
let redirect let redirect
| ssl = block "server" $ | ssl = block "server" $
semicolon $ semicolon $

View 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

View File

@ -1,28 +1,27 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
module System.Serverman.Services ( Service(..) 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 import Data.Aeson
| MySQL import Data.Maybe
| MongoDB import GHC.Generics
| VsFTPd
| LetsEncrypt
| SSHFs
deriving (Eq, Show)
class Configurable a where packageByOS :: Service -> OS -> [String]
configDirectory :: a -> FilePath packageByOS (Service { packages }) os = fromMaybe (fromJust $ lookup Unknown packages) (lookup os packages)
instance Configurable Service where info :: Service -> String
configDirectory NGINX = "/etc/nginx/" info s@(Service { config, packages, service, version, dependencies }) =
configDirectory MySQL = "/etc/mysql/" show s ++ (
configDirectory MongoDB = "/etc/mongodb" indent $
configDirectory VsFTPd = "/etc/vsftpd.conf" keyvalue [ ("config", config)
, ("pacakges", commas $ map (commas . snd) packages)
instance Read Service where , ("service", service)
readsPrec _ service , ("dependencies", commas $ map name dependencies)] ": "
| service == "nginx" = [(NGINX, [])] )
| service == "mysql" = [(MySQL, [])]
| service == "mongodb" = [(MongoDB, [])]
| service == "vsftpd" = [(VsFTPd, [])]
| service == "letsencrypt" = [(LetsEncrypt, [])]
| service == "sshfs" = [(SSHFs, [])]

View 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

View File

@ -6,9 +6,11 @@ module System.Serverman.Utils ( App (..)
, runApp , runApp
, keyvalue , keyvalue
, parseKeyValue , parseKeyValue
, splitAtElem
, semicolon , semicolon
, block , block
, indent , indent
, commas
, quote , quote
, removeTrailingNewline , removeTrailingNewline
, execIfMissing , execIfMissing
@ -44,16 +46,7 @@ module System.Serverman.Utils ( App (..)
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Data.Default.Class import Data.Default.Class
import Debug.Trace import System.Serverman.Types
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
keyvalue :: [(String, String)] -> String -> String keyvalue :: [(String, String)] -> String -> String
keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit 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 (key, value) = splitAt delimitIndex line
in (key, tail value) 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 :: String -> String
semicolon text = unlines $ map (++ ";") (lines text) semicolon text = unlines $ map (++ ";") (lines text)
block :: String -> String -> String block :: String -> String -> String
block blockName content = blockName ++ " {\n" ++ indent content ++ "}" 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 :: (Applicative f, Monad f, MonadIO f) => FilePath -> f () -> f ()
execIfMissing path action = do execIfMissing path action = do
exists <- liftIO $ doesFileExist path exists <- liftIO $ doesPathExist path
when (not exists) action when (not exists) action
@ -148,30 +155,6 @@ module System.Serverman.Utils ( App (..)
where where
specialCharacters = ["$"] 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 :: 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 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 [] let userArgument = if isJust maybeUser then ["echo", password, "|", "sudo -S", "-u", fromJust maybeUser] else []

View File

@ -1,12 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Term ( initialize ) where module System.Term ( initialize ) where
import System.Serverman.Services
import qualified System.Serverman as S import qualified System.Serverman as S
import System.Console.CmdArgs
import qualified System.Console.CmdArgs.Explicit as E
import System.Environment import System.Environment
import System.Directory import System.Directory
import System.Exit import System.Exit
@ -14,199 +12,229 @@ module System.Term ( initialize ) where
import Data.Maybe import Data.Maybe
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
import Data.Default.Class
import System.FilePath
import Data.List
import System.Serverman.Utils
initialize = do initialize = do
args <- getArgs 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-} liftIO $ print args
{-putStrLn $ "It's recommended that you don't run serverman as root."-} let params = parseParams args
{-putStrLn $ "Serverman will automatically use sudo whenever needed."-} liftIO $ print params
let fixArgs -- Fetch repository first
| null args = ["--help"] S.runApp $ do
| otherwise = args S.run (S.fetchRepository)
let result = E.process mode fixArgs state@(S.AppState { S.repository }) <- get
case result of case params of
Right (CmdArgs args help version _ _) -> (Params { listServices = True }) -> liftIO $ do
if isJust help then mapM_ print repository
putStrLn $ fromJust help (Params { install = Just service }) -> do
else if isJust version then os <- S.run S.detectOS
putStrLn $ fromJust version S.run (S.install (findService repository service) os)
else
case args of {-S.run (S.call (head repository) [])-}
p@(WebServerParams {}) -> webserverSetup p
p@(InstallParams {}) -> manualInstall p
p@(DatabaseParams {}) -> databaseSetup p
p@(FileSharingParams {}) -> fileSharingSetup p
Left err ->
print err
return () return ()
-- WEB SERVER where
data Params = WebServerParams { directory :: String findService repository n = fromJust $ find (\a -> S.name a == n) repository
, domain :: String
, port :: String
, forward :: String data Manage = Start | Stop deriving (Eq, Show)
, wService :: String data Params = Params { listServices :: Bool
, ssl :: Bool , install :: Maybe String
, email :: String , manage :: Maybe (Manage, String)
, wRemote :: String , update :: Bool
} , remote :: Maybe FilePath
| DatabaseParams { databaseName :: String , help :: Bool
, dService :: String } deriving (Show)
, dummyData :: Bool
, dUser :: String instance Default Params where
, dPass :: String def = Params { listServices = False
, dHost :: String , install = Nothing
, dRemote :: String , manage = Nothing
, remote = Nothing
, update = False
, help = False
} }
| FileSharingParams { fDirectory :: String parseParams :: [String] -> Params
, fUser :: String parseParams ("repository":"list":xs) = (parseParams xs) { listServices = True }
, fPass :: String parseParams ("repository":"update":xs) = (parseParams xs) { update = True }
, fPort :: String parseParams ("service":"start":s:xs) = (parseParams xs) { manage = Just (Start, s) }
, fWritable :: Bool parseParams ("service":"stop":s:xs) = (parseParams xs) { manage = Just (Stop, s) }
, fAnonymous :: Bool parseParams ("install":s:xs) = (parseParams xs) { install = Just s }
, fAnonymousWrite :: Bool parseParams ("--remote":s:xs) = (parseParams xs) { remote = Just s }
, fRecreateUser :: Bool parseParams ("--help":xs) = (parseParams xs) { help = True }
, fService :: String parseParams ("-h":xs) = (parseParams xs) { help = True }
, fRemote :: String parseParams [] = def
} parseParams _ = Params { help = True }
| InstallParams { iService :: String, remote :: String } {-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-}
{-}-}
deriving (Show, Data, Typeable) {-| FileSharingParams { fDirectory :: String-}
{-, fUser :: String-}
{-, fPass :: String-}
{-, fPort :: String-}
{-, fWritable :: Bool-}
{-, fAnonymous :: Bool-}
{-, fAnonymousWrite :: Bool-}
{-, fRecreateUser :: Bool-}
{-, fService :: String-}
{-, fRemote :: String-}
{-}-}
webserver = WebServerParams { directory = "/var/www/html/" &= typDir &= help "directory to serve static files from, defaults to /var/www/html/" {-| InstallParams { iService :: String, remote :: String }-}
, 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" {-deriving (Show, Data, Typeable)-}
, 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" {-webserver = WebServerParams { directory = "/var/www/html/" &= typDir &= help "directory to serve static files from, defaults to /var/www/html/" -}
, fUser = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user" {-, domain = "test.dev" &= typ "DOMAIN" &= help "domain/server name, defaults to test.dev"-}
, fPass = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password" {-, port = def &= typ "PORT" &= help "port number to listen to, defaults to 80 for http and 443 for https"-}
, fAnonymous = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous" {-, forward = def &= typ "PORT" &= help "the port to forward to (in case of a port-forwarding server)"-}
, fAnonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write" {-, ssl = False &= help "create a letsencrypt certificate for this domain, defaults to false"-}
, fWritable = True &= help "allow write operations, defaults to True" &= explicit &= name "writable" {-, email = def &= help "email required for registering your certificate"-}
, fPort = "21" &= help "service port, defaults to 21" &= explicit &= name "port" {-, wService = "nginx" &= help "service to build config for: nginx, defaults to nginx" &= explicit &= name "service"-}
, fService = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service" {-, wRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"-}
, fRecreateUser = False &= help "recreate the user" &= explicit &= name "recreate-user" {-} &= explicit &= name "webserver"-}
, fRemote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"
} &= explicit &= name "filesharing" {-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 {-install = InstallParams { iService = def &= argPos 0-}
, remote = def &= help "path to the file containing list of remote addresses in the format: user@host:port" {-, remote = def &= help "path to the file containing list of remote addresses in the format: user@host:port"-}
} &= explicit &= name "install" {-} &= explicit &= name "install"-}
webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email, wRemote }) = do {-webserverSetup (WebServerParams { directory, domain, port, ssl, forward, wService, email, wRemote }) = do-}
remoteSetup wRemote $ do {-remoteSetup wRemote $ do-}
when (ssl && null email) $ die "Email is required for generating a certificate" {-when (ssl && null email) $ die "Email is required for generating a certificate"-}
let serverType {-let serverType -}
| (not . null) forward = S.PortForwarding {-| (not . null) forward = S.PortForwarding-}
| otherwise = S.Static {-| otherwise = S.Static-}
let serviceName = read wService :: Service {-let serviceName = read wService-}
let portNumber {-let portNumber-}
| (not . null) port = port {-| (not . null) port = port-}
| ssl = "443" {-| ssl = "443"-}
| otherwise = "80" {-| otherwise = "80"-}
absoluteDirectory <- makeAbsolute directory {-absoluteDirectory <- makeAbsolute directory-}
let params = S.ServerParams { S.wDirectory = absoluteDirectory {-let params = S.ServerParams { S.wDirectory = absoluteDirectory-}
, S.domain = domain {-, S.domain = domain-}
, S.port = portNumber {-, S.port = portNumber-}
, S.ssl = ssl {-, S.ssl = ssl-}
, S.forward = forward {-, S.forward = forward-}
, S.serverType = serverType {-, S.serverType = serverType-}
, S.serverService = serviceName {-, S.serverService = serviceName-}
, S.email = email {-, S.email = email-}
} {-}-}
return $ S.detectOS >>= (S.install serviceName) {-return $ S.detectOS >>= (S.install serviceName)-}
>> S.detectOS >>= (S.start serviceName) {->> S.detectOS >>= (S.start serviceName)-}
>> S.newServer params {->> S.newServer params-}
manualInstall (InstallParams { iService, remote }) = {-manualInstall (InstallParams { iService, remote }) =-}
remoteSetup remote $ do {-remoteSetup remote $ do-}
let serviceName = read iService :: Service {-let serviceName = read iService-}
return $ S.detectOS >>= (S.install serviceName) {-return $ S.detectOS >>= (S.install serviceName)-}
>> S.detectOS >>= (S.start serviceName) {->> S.detectOS >>= (S.start serviceName)-}
databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do {-databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost, dRemote }) = do-}
remoteSetup dRemote $ do {-remoteSetup dRemote $ do-}
let serviceName = read dService {-let serviceName = read dService-}
let params = S.DatabaseParams { S.database = databaseName {-let params = S.DatabaseParams { S.database = databaseName-}
, S.databaseService = serviceName {-, S.databaseService = serviceName-}
, S.dummyData = dummyData {-, S.dummyData = dummyData-}
, S.databaseUser = dUser {-, S.databaseUser = dUser-}
, S.databasePass = dPass {-, S.databasePass = dPass-}
, S.databaseHost = dHost {-, S.databaseHost = dHost-}
} {-}-}
return $ S.detectOS >>= (S.install serviceName) {-return $ S.detectOS >>= (S.install serviceName)-}
>> S.detectOS >>= (S.start serviceName) {->> S.detectOS >>= (S.start serviceName)-}
>> S.newDatabase params {->> S.newDatabase params-}
fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser, fRemote }) = do {-fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser, fRemote }) = do-}
remoteSetup fRemote $ do {-remoteSetup fRemote $ do-}
let serviceName = read fService {-let serviceName = read fService-}
let params = S.FileSharingParams { S.fDirectory = fDirectory {-let params = S.FileSharingParams { S.fDirectory = fDirectory-}
, S.fUser = fUser {-, S.fUser = fUser-}
, S.fPass = fPass {-, S.fPass = fPass-}
, S.fPort = fPort {-, S.fPort = fPort-}
, S.fAnonymous = fAnonymous {-, S.fAnonymous = fAnonymous-}
, S.fAnonymousWrite = fAnonymousWrite {-, S.fAnonymousWrite = fAnonymousWrite-}
, S.fWritable = fWritable {-, S.fWritable = fWritable-}
, S.fService = serviceName {-, S.fService = serviceName-}
, S.fRecreateUser = fRecreateUser {-, S.fRecreateUser = fRecreateUser-}
} {-}-}
return $ S.detectOS >>= (S.install serviceName) {-return $ S.detectOS >>= (S.install serviceName)-}
>> S.detectOS >>= (S.start serviceName) {->> S.detectOS >>= (S.start serviceName)-}
>> S.newFileSharing params {->> S.newFileSharing params-}
remoteSetup file generateAction {-remoteSetup file generateAction-}
| null file = do {-| null file = do-}
action <- generateAction {-action <- generateAction-}
S.runApp $ {-S.runApp $-}
S.run action {-S.run action-}
return () {-return ()-}
| otherwise = do {-| otherwise = do-}
list <- liftIO $ map read . lines <$> readFile file {-list <- liftIO $ map read . lines <$> readFile file-}
action <- generateAction {-action <- generateAction-}
S.runApp $ S.run $ S.remote list action {-S.runApp $ S.run $ S.remote list action-}
return () {-return ()-}

View File

@ -1,66 +1,10 @@
# This file was automatically generated by 'stack init' flags: {}
# extra-package-dbs: []
# 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.
packages: packages:
- '.' - '.'
# Dependency packages to be pulled from upstream that are not in the resolver extra-deps:
# (e.g., acme-missiles-0.3) - stack-1.3.2
extra-deps: [] - store-0.3.1
- store-core-0.3
# Override default flag values for local packages and extra-deps - th-utilities-0.2.0.1
flags: {} resolver: lts-8.0
# 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