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

6
serverman.cabal
View File

@@ -19,11 +19,17 @@ library
, System.Serverman
, 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

17
src/System/Serverman.hs
View File

@@ -4,6 +4,7 @@ module System.Serverman ( run
, 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
@@ -22,18 +23,28 @@ module System.Serverman ( run
import System.Serverman.Actions.MySQL
import System.Serverman.Actions.MongoDB
import System.Serverman.Actions.FileSharing
import System.Serverman.Actions.VsFTPd
import Control.Monad.Free
run :: Action r -> IO r
run (Pure r) = return r
run (Free (NewWebServer params next))
| serverService params == NGINX = nginx params >> run next
| otherwise = run next
run (Free (DetectOS next)) = getOS >>= run . next
run (Free (Start os service next)) = startService 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

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

67
src/System/Term.hs
View File

@@ -16,16 +16,16 @@ module System.Term ( initialize ) where
initialize = do
args <- getArgs
let mode = cmdArgsMode $ modes [install, webserver, database]
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"
when (user == "ROOT") $ do
putStrLn $ "It's recommended that you don't run serverman as root."
putStrLn $ "Serverman will automatically use sudo whenever needed."
{-when (user == "ROOT") $ do-}
{-putStrLn $ "It's recommended that you don't run serverman as root."-}
{-putStrLn $ "Serverman will automatically use sudo whenever needed."-}
let fixArgs
| null args = ["--help"]
@@ -41,9 +41,10 @@ module System.Term ( initialize ) where
putStrLn $ fromJust version
else
case args of
p@(WebServerParams {}) -> webserverSetup p
p@(InstallParams {}) -> manualInstall p
p@(DatabaseParams {}) -> databaseSetup p
p@(WebServerParams {}) -> webserverSetup p
p@(InstallParams {}) -> manualInstall p
p@(DatabaseParams {}) -> databaseSetup p
p@(FileSharingParams {}) -> fileSharingSetup p
Left err ->
print err
@@ -66,6 +67,17 @@ module System.Term ( initialize ) where
, dHost :: String
}
| FileSharingParams { fDirectory :: String
, fUser :: String
, fPass :: String
, fPort :: String
, fWritable :: Bool
, fAnonymous :: Bool
, fAnonymousWrite :: Bool
, fRecreateUser :: Bool
, fService :: String
}
| InstallParams { iService :: String }
deriving (Show, Data, Typeable)
@@ -87,6 +99,17 @@ module System.Term ( initialize ) where
, dHost = "127.0.0.1" &= help "database's host, defaults to localhost" &= explicit &= name "host"
} &= 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"
} &= explicit &= name "filesharing"
install = InstallParams { iService = def &= argPos 0
} &= explicit &= name "install"
@@ -107,7 +130,7 @@ module System.Term ( initialize ) where
absoluteDirectory <- makeAbsolute directory
let params = S.ServerParams { S.directory = absoluteDirectory
let params = S.ServerParams { S.wDirectory = absoluteDirectory
, S.domain = domain
, S.port = portNumber
, S.ssl = ssl
@@ -130,15 +153,33 @@ module System.Term ( initialize ) where
databaseSetup (DatabaseParams { databaseName, dService, dummyData, dUser, dPass, dHost }) = do
let serviceName = read dService
let params = S.DatabaseParams { S.database = databaseName
let params = S.DatabaseParams { S.database = databaseName
, S.databaseService = serviceName
, S.dummyData = dummyData
, S.databaseUser = dUser
, S.databasePass = dPass
, S.databaseHost = dHost
, S.dummyData = dummyData
, S.databaseUser = dUser
, S.databasePass = dPass
, S.databaseHost = dHost
}
S.run $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newDatabase params
fileSharingSetup (FileSharingParams { fDirectory, fUser, fPass, fPort, fAnonymous, fAnonymousWrite, fWritable, fService, fRecreateUser }) = 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
}
S.run $ S.detectOS >>= (S.install serviceName)
>> S.detectOS >>= (S.start serviceName)
>> S.newFileSharing params