thereadme/serverman
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

feat(remote): run commands on remote machines

Browse Source
This commit is contained in:
Mahdi Dibaiee
2017-03-11 13:51:38 +03:30
parent 3a2e331d1a
commit f9d802ee71
12 changed files with 395 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/System/Serverman/Actions/Env.hs
View File

@@ -4,6 +4,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
import Data.List
import System.IO.Error
import Data.Either
import Data.Char
data OS = Debian | Arch | Mac | Unknown deriving (Show, Eq)
@@ -12,7 +13,7 @@ module System.Serverman.Actions.Env (OS(..), getOS) where
deb_release <- execute "cat" ["/etc/lsb-release"] "" False
mac_release <- execute "sw_vers" ["-productName"] "" False
let release = head $ rights [arch_release, deb_release, mac_release]
let release = map toLower . head . rights $ [arch_release, deb_release, mac_release]
distro
| or $ map (`isInfixOf` release) ["ubuntu", "debian", "raspbian"] = Debian
| "arch" `isInfixOf` release = Arch

15
src/System/Serverman/Actions/Install.hs
View File

@@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module System.Serverman.Actions.Install (installService, package, dependencies) where
import System.Serverman.Action
import System.Serverman.Utils
@@ -8,8 +10,9 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
import System.IO.Error
import System.Process
import Control.Concurrent.Async
import Control.Monad.Free
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans.Control
class Installable a where
dependencies :: a -> [a]
@@ -32,7 +35,7 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
package SSHFs _ = "sshfs"
installService :: Service -> OS -> IO ()
installService :: Service -> OS -> App ()
installService service os = do
forM_ (dependencies service) (`installService` os)
@@ -43,11 +46,13 @@ module System.Serverman.Actions.Install (installService, package, dependencies)
_ -> ("echo", ["Unknown operating system"])
pkg = package service os
process <- async $ do
process <- liftedAsync $ do
result <- executeRoot (fst base) (snd base ++ [pkg]) "" True
case result of
Left err -> return ()
Right _ -> do
putStrLn $ "installed " ++ show service ++ "."
wait process
liftIO $ putStrLn $ "installed " ++ show service ++ "."
liftIO $ wait process
return ()

5
src/System/Serverman/Actions/MongoDB.hs
View File

@@ -8,10 +8,11 @@ module System.Serverman.Actions.MongoDB (mongodb) where
import Data.List hiding (delete)
import qualified Data.Text as T
import Control.Monad
import Control.Monad.State
import System.IO.Error
mongodb :: DatabaseParams -> IO ()
mongodb (DatabaseParams { database, dummyData, databaseHost }) = do
mongodb :: DatabaseParams -> App ()
mongodb (DatabaseParams { database, dummyData, databaseHost }) = liftIO $ do
result <- tryIOError $ connect (readHostPort databaseHost)
case result of

5
src/System/Serverman/Actions/MySQL.hs
View File

@@ -7,9 +7,10 @@ module System.Serverman.Actions.MySQL (mysql) where
import qualified Data.ByteString.Char8 as BS
import Data.List
import Control.Monad
import Control.Monad.State
mysql :: DatabaseParams -> IO ()
mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = do
mysql :: DatabaseParams -> App ()
mysql (DatabaseParams { database, dummyData, databaseUser, databasePass, databaseHost }) = liftIO $ do
conn <- connect $ defaultConnectInfo { connectUser = databaseUser, connectPassword = databasePass, connectHost = databaseHost }
query conn $ BS.pack ("CREATE DATABASE IF NOT EXISTS " ++ database)

53
src/System/Serverman/Actions/Nginx.hs
View File

@@ -12,10 +12,11 @@ module System.Serverman.Actions.Nginx (nginx) where
import System.Process
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.State
import Control.Monad.Free
import Data.List
nginx :: ServerParams -> IO ()
nginx :: ServerParams -> App ()
nginx params@(ServerParams { ssl, serverService, domain, wDirectory, serverType, email }) =
do
-- Turn SSL off at first, because we have not yet received a certificate
@@ -25,62 +26,66 @@ module System.Serverman.Actions.Nginx (nginx) where
path = parent </> domain
targetDir = wDirectory
createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent
liftIO $ do
createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent
writeIncludeStatementIfMissing mainConfig parent
writeIncludeStatementIfMissing mainConfig parent
when ssl $ do
let sslPath = configDirectory serverService </> "ssl.conf"
writeFileIfMissing sslPath nginxSSL
putStrLn $ "wrote ssl configuration to " ++ sslPath
when ssl $ do
let sslPath = configDirectory serverService </> "ssl.conf"
writeFileIfMissing sslPath nginxSSL
putStrLn $ "wrote ssl configuration to " ++ sslPath
writeFile path content
writeFile path content
putStrLn $ "wrote your configuration file to " ++ path
wait =<< restart
putStrLn $ "wrote your configuration file to " ++ path
liftIO . wait =<< restart
when ssl $ do
let dhparamPath = "/etc/ssl/certs/dhparam.pem"
dhExists <- doesFileExist dhparamPath
dhExists <- liftIO $ doesFileExist dhparamPath
when (not dhExists) $ do
dhparam <- async $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True
wait dhparam
dhparam <- liftedAsync $ executeRoot "openssl" ["dhparam", "-out", dhparamPath, "2048"] "" True
liftIO $ wait dhparam
return ()
case serverType of
Static -> do
letsencrypt <- async $ createCert path "letsencrypt"
letsencrypt <- liftedAsync $ createCert path "letsencrypt"
wait letsencrypt
_ -> do
liftIO $ wait letsencrypt
return ()
_ -> liftIO $ do
putStrLn $ "you should use letsencrypt to create a certificate for your domain"
putStrLn $ "and put it in /etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem"
putStrLn $ "my suggestion is running this command:"
putStrLn $ "sudo letsencrypt certonly --webroot --webroot-path <YOUR_APPLICATION_DIRECTORY> -d " ++ domain
putStrLn $ "for more information, see: https://certbot.eff.org/"
liftIO $ putStrLn $ "for more information, see: https://certbot.eff.org/"
return ()
where
restart = async $ do
restart = liftedAsync $ do
result <- restartService "nginx"
case result of
Left err -> return ()
Right _ ->
putStrLn $ "restarted " ++ show serverService
liftIO $ putStrLn $ "restarted " ++ show serverService
createCert path cmd = do
result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", wDirectory, "-d", domain, "--email", email, "--agree-tos", "-n"] "" False
case result of
Left _ -> if cmd == "letsencrypt" then createCert path "certbot" else return ()
Right stdout -> do
putStrLn stdout
liftIO $ putStrLn stdout
when (not ("error" `isInfixOf` stdout)) $ do
writeFile path (show params)
wait =<< restart
liftIO $ writeFile path (show params)
liftIO . wait =<< restart
return ()
writeIncludeStatementIfMissing path target = do
content <- readFile path

93
src/System/Serverman/Actions/Remote.hs
View File

@@ -1,38 +1,89 @@
module System.Serverman.Actions.Remote ( runRemotely
, Address) where
import System.Serverman.Utils
import System.Unix.Chroot
import Data.List
import System.Directory
import System.IO
import System.FilePath
import System.Posix.Env
import System.Posix.Files
import Control.Monad
import Data.Maybe
import Data.IORef
import Control.Monad.State
type Host = String
type Port = String
type User = String
data Address = Address Host Port User
import Debug.Trace
runRemotely :: Address -> IO r -> IO ()
runRemotely :: Address -> App r -> App ()
runRemotely addr@(Address host port user) action = do
let path = "/tmp/serverman/" </> show addr
let servermanAddr = Address host port "serverman"
p = if null port then [] else ["-p", port]
connection = takeWhile (/= ':') (show addr)
smConnection = "serverman@" ++ host
path = "/tmp/serverman/" </> connection
createDirectoryIfMissing True path
home <- liftIO getHomeDirectory
execute "sshfs" [show addr, path] "" True
let keyPath = home </> ".ssh/serverman"
pubPath = keyPath <.> "pub"
liftIO $ createDirectoryIfMissing True path
execute "fusermount" ["-u", path] "" False
let sftpOptions = ["-o", "sftp_server=sudo -u serverman /usr/lib/openssh/sftp-server"]
result <- execute "sshfs" (p ++ noPassword ++ sftpOptions ++ ["-o", "nonempty", "-o", "IdentityFile=" ++ keyPath, smConnection ++ ":/", path]) "" True
case result of
Right _ -> do
state <- get
put $ state { remoteMode = Just (servermanAddr, keyPath) }
action
return ()
Left _ -> do
liftIO $ do
putStrLn $ "it seems to be the first time you are using serverman for configuring " ++ show addr
putStrLn $ "remotely. serverman will create a user, and add it to sudoers file. an ssh key will be created"
putStrLn $ "and that will be used for connecting to the server from now on."
putStrLn $ "you might be prompted for password if you are not using SSH key authentication."
putStrLn $ "Enter password for " ++ connection
home <- liftIO getHomeDirectory
password <- liftIO getPassword
execIfMissing keyPath $ execute "ssh-keygen" ["-N", "", "-f", keyPath] "" True >> return ()
publicKey <- liftIO $ readFile pubPath
let runCommand a b = execRemote addr Nothing (Just "root") password a b "" Nothing True
runServerman a b = execRemote addr (Just keyPath) (Just "serverman") password a b "" Nothing True
(Right encryptedPassword) <- execute "openssl" ["passwd", "-1", "serverman"] "" True
runCommand "useradd" ["-m", "-p", (quote . removeTrailingNewline) encryptedPassword, "serverman"]
runCommand "echo" ["'serverman ALL=(ALL) NOPASSWD: ALL'", ">>", "/etc/sudoers"]
runServerman "mkdir" ["/home/serverman/.ssh", "-p"]
runServerman "touch" ["/home/serverman/.ssh/authorized_keys"]
runServerman "echo" [quote publicKey, ">>", "/home/serverman/.ssh/authorized_keys"]
return ()
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
noPassword = ["-o", "PasswordAuthentication=no", "-o", "PubkeyAuthentication=yes"]
where
readHostPort str = span (== ':') str
chroot path (key, value)
| key == "PATH" = (key, path ++ concatMap (modPath path) value)
| otherwise = (key, value)
instance Show Address where
show (Address host port user) = user ++ "@" ++ host ++ ":" ++ port
modPath path c
| c == ':' = ":" ++ path
| otherwise = [c]

6
src/System/Serverman/Actions/Start.hs
View File

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

14
src/System/Serverman/Actions/VsFTPd.hs
View File

@@ -15,8 +15,9 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where
import Control.Monad.Free
import Data.List
import Data.Either
import Control.Monad.State
vsftpd :: FileSharingParams -> IO ()
vsftpd :: FileSharingParams -> App ()
vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) =
do
let content = show params
@@ -30,14 +31,13 @@ module System.Serverman.Actions.VsFTPd (vsftpd) where
executeRoot "useradd" [fUser, "-d", fDirectory, "-G", "ftp", "-p", encryptedPassword] "" True
renameFileIfMissing original (original ++ ".backup")
writeFile original content
writeFile userList fUser
liftIO $ do
renameFileIfMissing original (original ++ ".backup")
writeFile original content
writeFile userList fUser
result <- restartService "vsftpd"
case result of
Left err -> return ()
Right _ ->
putStrLn $ "restarted " ++ show fService
liftIO $ putStrLn $ "restarted " ++ show fService