feat: remote action

This commit is contained in:
Mahdi Dibaiee 2017-03-05 15:49:09 +03:30
parent 48c1208dc7
commit 3a2e331d1a
12 changed files with 254 additions and 2 deletions

View File

@ -33,6 +33,7 @@ library
, System.Serverman.Actions.Install
, System.Serverman.Actions.Env
, System.Serverman.Actions.Start
, System.Serverman.Actions.Remote
, System.Serverman.Services
build-depends: base >= 4.7 && < 5
, free >= 4.12.4 && < 5

View File

@ -15,6 +15,7 @@ module System.Serverman ( run
import System.Serverman.Actions.Env
import System.Serverman.Actions.Install
import System.Serverman.Actions.Start
import System.Serverman.Actions.Remote
import System.Serverman.Actions.WebServer
import System.Serverman.Actions.Nginx
@ -47,4 +48,5 @@ module System.Serverman ( run
| 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

View File

@ -7,12 +7,14 @@ module System.Serverman.Action ( ActionF(..)
, newFileSharing
, start
, 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.Remote
import System.Serverman.Utils
import System.Serverman.Services
@ -31,6 +33,7 @@ module System.Serverman.Action ( ActionF(..)
| NewFileSharing FileSharingParams x
| DetectOS (OS -> x)
| Install Service OS x
| Remote [Address] (Action ()) x
| Start Service OS x
instance Functor ActionF where
@ -40,6 +43,7 @@ module System.Serverman.Action ( ActionF(..)
fmap f (Install service os x) = Install service os (f x)
fmap f (Start service os x) = Start service os (f x)
fmap f (DetectOS x) = DetectOS (f . x)
fmap f (Remote addr action x) = Remote addr action (f x)
type Action = Free ActionF
@ -60,3 +64,6 @@ module System.Serverman.Action ( ActionF(..)
detectOS :: Action OS
detectOS = liftF $ DetectOS id
remote :: [Address] -> Action () -> Action ()
remote addrs action = liftF $ Remote addrs action ()

View File

@ -30,6 +30,8 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
package VsFTPd _ = "vsftpd"
package SSHFs _ = "sshfs"
installService :: Service -> OS -> IO ()
installService service os = do
forM_ (dependencies service) (`installService` os)

View File

@ -0,0 +1,38 @@
module System.Serverman.Actions.Remote ( runRemotely
, Address) where
import System.Serverman.Utils
import Data.List
import System.Directory
import System.IO
import System.FilePath
type Host = String
type Port = String
type User = String
data Address = Address Host Port User
runRemotely :: Address -> IO r -> IO ()
runRemotely addr@(Address host port user) action = do
let path = "/tmp/serverman/" </> show addr
createDirectoryIfMissing True path
execute "sshfs" [show addr, path] "" True
return ()
instance Read Address where
readsPrec _ addr
| '@' `elem` addr =
let (user, rest) = span (== '@') addr
(host, port) = readHostPort rest
in [(Address host port user, [])]
| otherwise =
let (host, port) = readHostPort addr
in [(Address host port "", [])]
where
readHostPort str = span (== ':') str
instance Show Address where
show (Address host port user) = user ++ "@" ++ host ++ ":" ++ port

View File

@ -6,6 +6,7 @@ module System.Serverman.Services ( Service(..)
| MongoDB
| VsFTPd
| LetsEncrypt
| SSHFs
deriving (Eq, Show)
class Configurable a where
@ -24,3 +25,4 @@ module System.Serverman.Services ( Service(..)
| service == "mongodb" = [(MongoDB, [])]
| service == "vsftpd" = [(VsFTPd, [])]
| service == "letsencrypt" = [(LetsEncrypt, [])]
| service == "sshfs" = [(SSHFs, [])]

View File

@ -6,6 +6,7 @@ module System.Serverman.Utils ( keyvalue
, renameFileIfMissing
, commandError
, appendAfter
, exec
, execute
, restartService
, executeRoot) where
@ -58,11 +59,15 @@ module System.Serverman.Utils ( keyvalue
commandError command = "[Error] an error occured while running: " ++ command ++ "\nplease try running the command manually."
execute :: String -> [String] -> String -> Bool -> IO (Either String String)
execute cmd args stdin logErrors = do
execute cmd args stdin logErrors = exec cmd args stdin Nothing logErrors
exec :: String -> [String] -> String -> Maybe FilePath -> Bool -> IO (Either String String)
exec cmd args stdin cwd logErrors = do
let command = cmd ++ " " ++ intercalate " " args
cp = (proc cmd args) { cwd = cwd }
process <- async $ do
result <- tryIOError $ readProcessWithExitCode cmd args stdin
result <- tryIOError $ readCreateProcessWithExitCode cp stdin
case result of
Right (ExitSuccess, stdout, _) -> return $ Right stdout

View File

@ -0,0 +1,45 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.Database (mode, handle, Params(..)) where
import System.Console.CmdArgs hiding (name)
import qualified System.Console.CmdArgs as C (name)
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory
data Params = Params { name :: String
, service :: String
, dummyData :: Bool
, user :: String
, pass :: String
, host :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { name = "test" &= help "database name, defaults to test"
, service = "mysql" &= help "service to setup: mysql, defaults to mysql"
, dummyData = False &= help "generate dummy data in the database" &= explicit &= C.name "dummy-data"
, user = "root" &= help "database's username, defaults to root"
, pass = "" &= help "database's password, defaults to blank string"
, host = "127.0.0.1" &= help "database's host, defaults to localhost"
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir
} &= explicit &= C.name "database"
handle (Params { name, service, dummyData, user, pass, host, remote }) =
R.handle remote $ do
let serviceName = read service
let params = S.DatabaseParams { S.database = name
, S.databaseService = serviceName
, S.dummyData = dummyData
, S.databaseUser = user
, S.databasePass = pass
, S.databaseHost = host
}
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newDatabase params

View File

@ -0,0 +1,53 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.FileSharing (mode, handle, Params(..)) where
import System.Console.CmdArgs
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory hiding (writable)
data Params = Params { directory :: String
, user :: String
, pass :: String
, port :: String
, writable :: Bool
, anonymous :: Bool
, anonymousWrite :: Bool
, recreateUser :: Bool
, service :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { directory = "/srv/ftp/" &= typDir &= help "directory to share, defaults to /srv/ftp/" &= explicit &= name "directory"
, user = "serverman" &= typDir &= help "username, defaults to serverman" &= explicit &= name "user"
, pass = "" &= help "password, defaults to serverman (please change this to avoid security risks)" &= explicit &= name "password"
, anonymous = False &= help "allow anonymous connections, defaults to False" &= explicit &= name "anonymous"
, anonymousWrite = False &= help "allow anonymous write operations, defaults to False" &= explicit &= name "anonymous-write"
, writable = True &= help "allow write operations, defaults to True" &= explicit &= name "writable"
, port = "21" &= help "service port, defaults to 21" &= explicit &= name "port"
, service = "vsftpd" &= help "service to use for file sharing, defaults to vsftpd" &= explicit &= name "service"
, recreateUser = False &= help "recreate the user" &= explicit &= name "recreate-user"
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
} &= explicit &= name "filesharing"
handle (Params { directory, user, pass, port, anonymous, anonymousWrite, writable, service, recreateUser, remote }) =
R.handle remote $ do
let serviceName = read service
let params = S.FileSharingParams { S.fDirectory = directory
, S.fUser = user
, S.fPass = pass
, S.fPort = port
, S.fAnonymous = anonymous
, S.fAnonymousWrite = anonymousWrite
, S.fWritable = writable
, S.fService = serviceName
, S.fRecreateUser = recreateUser
}
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newFileSharing params

View File

@ -0,0 +1,27 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.Install (mode, handle, Params(..)) where
import System.Console.CmdArgs
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory
data Params = Params { service :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { service = def &= argPos 0
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
}
handle (Params { service, remote }) =
R.handle remote $ do
let serviceName = read service
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)

10
src/System/Term/Remote.hs Normal file
View File

@ -0,0 +1,10 @@
module System.Term.Remote (handle) where
import qualified System.Serverman as S
handle file generateAction
| null file = S.run =<< generateAction
| otherwise = do
list <- map read . lines <$> readFile file
action <- generateAction
S.run $ S.remote list action

View File

@ -0,0 +1,60 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.Term.WebServer (mode, handle, Params(..)) where
import System.Console.CmdArgs
import qualified System.Serverman as S
import qualified System.Term.Remote as R
import Control.Monad
import System.Exit
import System.Directory
data Params = Params { directory :: String
, domain :: String
, port :: String
, forward :: String
, service :: String
, ssl :: Bool
, email :: String
, remote :: FilePath
} deriving (Show, Data, Typeable)
mode = Params { 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"
, service = "nginx" &= help "service to build config for: nginx, defaults to nginx"
, remote = def &= help "file to read remote hosts from. each line should contain a host:port" &= typDir &= explicit &= name "remote"
} &= explicit &= name "webserver"
handle (Params { directory, domain, port, ssl, forward, service, email, remote }) =
R.handle remote $ do
when (ssl && null email) $ die "Email is required for generating a certificate"
let serverType
| (not . null) forward = S.PortForwarding
| otherwise = S.Static
let serviceName = read service :: S.Service
let portNumber
| (not . null) port = port
| ssl = "443"
| otherwise = "80"
absoluteDirectory <- makeAbsolute directory
let params = S.ServerParams { S.wDirectory = absoluteDirectory
, S.domain = domain
, S.port = portNumber
, S.ssl = ssl
, S.forward = forward
, S.serverType = serverType
, S.serverService = serviceName
, S.email = email
}
return $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newServer params