feat(vsftpd): file sharing via vsftpd

serverman.cabal

@@ -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

src/System/Serverman.hs

@@ -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
+
+

src/System/Serverman/Action.hs

@@ -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)

src/System/Serverman/Actions/FileSharing.hs

@@ -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"

src/System/Serverman/Actions/Nginx.hs

@@ -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

src/System/Serverman/Actions/VsFTPd.hs

@@ -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

src/System/Serverman/Actions/WebServer.hs

@@ -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 
+    show (ServerParams { wDirectory, domain, port, forward, email, ssl, serverType, serverService }) 
-      | serverService conf == NGINX = 
+      | 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 = [ ("ssl_certificate", "/etc/letsencrypt/live/" ++ domain ++ "/fullchain.pem")
-                             , ("ssl_certificate_key", "/etc/letsencrypt/live/" ++ domain conf ++ "/privkey.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)
+                                    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" $ keyvalue base ++ proxyBlock) ++ "\n" ++ redirect
+                in (block "server" $ semicolon (keyvalue base " ") ++ proxyBlock) ++ "\n" ++ redirect
 
       | otherwise = "Unknown service provider"

src/System/Serverman/Services.hs

@@ -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

src/System/Serverman/Utils.hs

@@ -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 :: [(String, String)] -> String -> String
-  keyvalue ((a, b):xs) = a ++ " " ++ b ++ ";\n" ++ keyvalue xs
+  keyvalue ((a, b):xs) delimit = a ++ delimit ++ b ++ "\n" ++ keyvalue xs delimit
-  keyvalue [] = ""
+  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

src/System/Term.hs

@@ -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
+    {-when (user == "ROOT") $ do-}
-      putStrLn $ "It's recommended that you don't run serverman as root."
+      {-putStrLn $ "It's recommended that you don't run serverman as root."-}
-      putStrLn $ "Serverman will automatically use sudo whenever needed."
+      {-putStrLn $ "Serverman will automatically use sudo whenever needed."-}
 
     let fixArgs
                   | null args = ["--help"]
@@ -44,6 +44,7 @@ module System.Term ( initialize ) where
             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
@@ -142,3 +165,21 @@ module System.Term ( initialize ) where
          >> 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
+