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