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

feat(vsftpd): file sharing via vsftpd

Browse Source
This commit is contained in:
Mahdi Dibaiee
2017-03-04 13:47:24 +03:30
parent 3595464b11
commit 48c1208dc7
10 changed files with 202 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/System/Serverman/Action.hs
View File

@ -36,7 +36,7 @@ module System.Serverman.Action ( ActionF(..)
instance Functor ActionF where
fmap f (NewWebServer params x) = NewWebServer params (f x)
fmap f (NewDatabase params x) = NewDatabase params (f x)
fmap f (NewSharedFolder params x) = NewSharedFolder params (f x)
fmap f (NewFileSharing params x) = NewFileSharing params (f x)
fmap f (Install service os x) = Install service os (f x)
fmap f (Start service os x) = Start service os (f x)
fmap f (DetectOS x) = DetectOS (f . x)

37
src/System/Serverman/Actions/FileSharing.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.FileSharing (FileSharingParams(..)) where
import System.Serverman.Services
import System.Serverman.Utils
data FileSharingParams = FileSharingParams { fDirectory :: FilePath
, fUser :: String
, fPass :: String
, fPort :: String
, fWritable :: Bool
, fAnonymous :: Bool
, fAnonymousWrite :: Bool
, fRecreateUser :: Bool
, fService :: Service
} deriving (Eq)
instance Show FileSharingParams where
show (FileSharingParams { fDirectory, fUser, fPass, fPort, fWritable, fAnonymous, fAnonymousWrite, fService })
| fService == VsFTPd =
let boolToEnglish True = "YES"
boolToEnglish False = "NO"
in
keyvalue [ ("anonymous_enable", boolToEnglish fAnonymous)
, ("write_enable", boolToEnglish fWritable)
, ("allow_writeable_chroot", boolToEnglish fWritable)
, ("anon_upload_enable", boolToEnglish fAnonymousWrite)
, ("anon_mkdir_write_enable", boolToEnglish fAnonymousWrite)
, ("listen", "YES")
, ("userlist_enable", "YES")
, ("userlist_file", "/etc/vsftpd-serverman-user-list")
, ("userlist_deny", "NO")
, ("chroot_local_user", "YES")
, ("xferlog_enable", "YES")
, ("local_enable", "YES")] "="
| otherwise = "Unknown service provider"

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

@ -16,14 +16,14 @@ module System.Serverman.Actions.Nginx (nginx) where
import Data.List
nginx :: ServerParams -> IO ()
nginx params@(ServerParams { ssl, serverService, domain, directory, serverType, email }) =
nginx params@(ServerParams { ssl, serverService, domain, wDirectory, serverType, email }) =
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"
path = parent </> domain
targetDir = directory
targetDir = wDirectory
createDirectoryIfMissing True targetDir
createDirectoryIfMissing True parent
@ -65,14 +65,14 @@ module System.Serverman.Actions.Nginx (nginx) where
return ()
where
restart = async $ do
result <- executeRoot "systemctl" ["restart", "nginx"] "" True
result <- restartService "nginx"
case result of
Left err -> return ()
Right _ ->
putStrLn $ "restarted " ++ show serverService
createCert path cmd = do
result <- executeRoot cmd ["certonly", "--webroot", "--webroot-path", directory, "-d", domain, "--email", email, "--agree-tos", "-n"] "" False
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

43
src/System/Serverman/Actions/VsFTPd.hs Normal file
View File

@ -0,0 +1,43 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.VsFTPd (vsftpd) where
import System.Serverman.Utils
import System.Serverman.Services
import System.Serverman.Actions.FileSharing
import System.Directory
import System.IO
import System.IO.Error
import System.FilePath
import System.Process
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Free
import Data.List
import Data.Either
vsftpd :: FileSharingParams -> IO ()
vsftpd params@(FileSharingParams { fDirectory, fPort, fUser, fPass, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) =
do
let content = show params
original = configDirectory fService
userList = takeDirectory original </> "vsftpd-serverman-user-list"
when fRecreateUser $ executeRoot "userdel" [fUser] "" True >> return ()
(Right opensslResponse) <- execute "openssl" ["passwd", "-1", fPass] "" True
let encryptedPassword = head . lines $ opensslResponse
executeRoot "useradd" [fUser, "-d", fDirectory, "-G", "ftp", "-p", encryptedPassword] "" True
renameFileIfMissing original (original ++ ".backup")
writeFile original content
writeFile userList fUser
result <- restartService "vsftpd"
case result of
Left err -> return ()
Right _ ->
putStrLn $ "restarted " ++ show fService

42
src/System/Serverman/Actions/WebServer.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE NamedFieldPuns #-}
module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) where
import System.Serverman.Utils
import System.Serverman.Services
@ -5,7 +7,7 @@ module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) whe
import Control.Monad.Free
data ServerType = Static | PortForwarding deriving (Show, Eq)
data ServerParams = ServerParams { directory :: String
data ServerParams = ServerParams { wDirectory :: FilePath
, domain :: String
, port :: String
, forward :: String
@ -15,41 +17,43 @@ module System.Serverman.Actions.WebServer (ServerParams(..), ServerType(..)) whe
, serverService :: Service
} deriving (Eq)
instance Show ServerParams where
show conf
| serverService conf == NGINX =
show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService })
| serverService == NGINX =
let redirect
| ssl conf = block "server" $
| ssl = block "server" $
semicolon $
keyvalue ([ ("listen", "80")
, ("listen", "[::]:80")
, ("server_name", domain conf)
, ("server_name", domain)
, ("rewrite", "^ https://$server_name$request_uri? permanent")
])
]) " "
| otherwise = ""
https
| ssl conf = [ ("ssl_certificate", "/etc/letsencrypt/live/" ++ domain conf ++ "/fullchain.pem")
, ("ssl_certificate_key", "/etc/letsencrypt/live/" ++ domain conf ++ "/privkey.pem")
, ("include", "ssl.conf")]
| ssl = [ ("ssl_certificate", "/etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem")
, ("ssl_certificate_key", "/etc/letsencrypt/live/" ++ domain ++ "/privkey.pem")
, ("include", "ssl.conf")]
| otherwise = []
listen = port conf ++ (if ssl conf then " ssl" else "")
listen = port ++ (if ssl then " ssl" else "")
base = [ ("server_name", domain conf)
base = [ ("server_name", domain)
, ("listen", listen)
, ("listen", "[::]:" ++ listen)
, ("index", "index.html index.html index.php")
] ++ https
in
case serverType conf of
case serverType of
Static ->
(block "server" $ keyvalue (base ++ [("root", directory conf)])) ++ "\n" ++ redirect
(block "server" $ keyvalue (base ++ [("root", wDirectory)]) " ") ++ "\n" ++ redirect
PortForwarding ->
let proxyBlock = block "location /" $
keyvalue ([ ("proxy_pass", "http://127.0.0.1:" ++ forward conf)
, ("proxy_set_header", "X-Forwarded-Host $host")
, ("proxy_set_header", "X-Forwarded-Server $host")
, ("proxy_set_header", "X-Forwarded-For $proxy_add_x_forwarded_for")
])
in (block "server" $ keyvalue base ++ proxyBlock) ++ "\n" ++ redirect
semicolon $
keyvalue ([ ("proxy_pass", "http://127.0.0.1:" ++ forward)
, ("proxy_set_header", "X-Forwarded-Host $host")
, ("proxy_set_header", "X-Forwarded-Server $host")
, ("proxy_set_header", "X-Forwarded-For $proxy_add_x_forwarded_for")
]) " "
in (block "server" $ semicolon (keyvalue base " ") ++ proxyBlock) ++ "\n" ++ redirect
| otherwise = "Unknown service provider"

2
src/System/Serverman/Services.hs
View File

@ -15,7 +15,7 @@ module System.Serverman.Services ( Service(..)
configDirectory NGINX = "/etc/nginx/"
configDirectory MySQL = "/etc/mysql/"
configDirectory MongoDB = "/etc/mongodb"
configDirectory VsFTPd = "/etc/vsftpd"
configDirectory VsFTPd = "/etc/vsftpd.conf"
instance Read Service where
readsPrec _ service

22
src/System/Serverman/Utils.hs
View File

@ -1,10 +1,13 @@
module System.Serverman.Utils ( keyvalue
, semicolon
, block
, indent
, writeFileIfMissing
, renameFileIfMissing
, commandError
, appendAfter
, execute
, restartService
, executeRoot) where
import System.IO
@ -17,9 +20,12 @@ module System.Serverman.Utils ( keyvalue
import Control.Exception
import System.Exit
keyvalue :: [(String, String)] -> String
keyvalue ((a, b):xs) = a ++ " " ++ b ++ ";\n" ++ keyvalue xs
keyvalue [] = ""
keyvalue :: [(String, String)] -> String -> String
keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit
keyvalue [] _ = ""
semicolon :: String -> String
semicolon text = unlines $ map (++ ";") (lines text)
block :: String -> String -> String
block blockName content = blockName ++ " {\n" ++ indent content ++ "}"
@ -31,6 +37,13 @@ module System.Serverman.Utils ( keyvalue
when (not exists) $ do
writeFile path content
renameFileIfMissing :: FilePath -> String -> IO ()
renameFileIfMissing path content = do
exists <- doesFileExist path
when (not exists) $ do
renameFile path content
appendAfter :: String -> String -> String -> String
appendAfter content after line =
let ls = lines content
@ -69,5 +82,8 @@ module System.Serverman.Utils ( keyvalue
wait process
restartService :: String -> IO (Either String String)
restartService service = executeRoot "systemctl" ["restart", service] "" True
executeRoot :: String -> [String] -> String -> Bool -> IO (Either String String)
executeRoot cmd args stdin logErrors = execute "sudo" (cmd:args) stdin logErrors