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.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

View File

@ -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

View File

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

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
import System.Serverman.Utils
import System.Serverman.Types
import System.Process
import Data.List
import System.IO.Error
import Data.Either
import Data.Char
data OS = Debian | Arch | Mac | Unknown deriving (Show, Eq)
getOS = do
arch_release <- execute "cat" ["/etc/os-release"] "" False
deb_release <- execute "cat" ["/etc/lsb-release"] "" False

View File

@ -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

View File

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

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

View File

@ -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"

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

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 }) =
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 ()

View File

@ -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 $

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(..)
, 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)] ": "
)

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
, 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 []

View File

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

View File

@ -1,66 +1,10 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-8.0
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
flags: {}
extra-package-dbs: []
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
extra-deps:
- stack-1.3.2
- store-0.3.1
- store-core-0.3
- th-utilities-0.2.0.1
resolver: lts-8.0