Main.hs

   1 {-# LANGUAGE CPP #-}
   2 import           Control.Monad
   3 import           Data.List
   4 import           Data.Maybe
   5 import           Network
   6 import           Network.HTTP.Lucu
   7 import           Rakka.Environment
   8 import           Rakka.Resource.Index
   9 import           Rakka.Resource.Object
  10 import           Rakka.Resource.Render
  11 import           Subversion
  12 import           System.Console.GetOpt
  13 import           System.Directory
  14 import           System.Environment
  15 import           System.Exit
  16 import           System.IO
  17 import           System.Log.Handler.Simple
  18 import           System.Log.Logger
  19 import           System.Posix.Files
  20 import           System.Posix.Types
  21 import           System.Posix.User
  22
  23 logger = "Main"
  24
  25
  26 data CmdOpt
  27     = OptPortNum   PortNumber
  28     | OptLSDir     FilePath
  29     | OptUserName  String
  30     | OptGroupName String
  31     | OptLogLevel  Priority
  32     | OptDisableStderrLog
  33     | OptHelp
  34     deriving (Eq, Show)
  35
  36
  37 defaultPort :: PortNumber
  38 defaultPort = fromIntegral 8080
  39
  40 defaultLocalStateDir :: FilePath
  41 defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP
  42
  43 defaultUserName :: String
  44 defaultUserName = "daemon"
  45
  46 defaultGroupName :: String
  47 defaultGroupName = "daemon"
  48
  49
  50 defaultLogLevel :: Priority
  51 defaultLogLevel = NOTICE
  52
  53
  54 options :: [OptDescr CmdOpt]
  55 options = [ Option ['p'] ["port"]
  56                    (ReqArg (OptPortNum . fromIntegral . read) "NUM")
  57                    ("Port number to listen. (default: " ++ show defaultPort ++ ")")
  58
  59           , Option ['d'] ["localstatedir"]
  60                    (ReqArg OptLSDir "DIR")
  61                    ("Path to the database directory. (default: " ++ defaultLocalStateDir ++ ")")
  62
  63           , Option ['u'] ["user"]
  64                    (ReqArg OptUserName "USER")
  65                    ("Which user to setuid. (default: " ++ defaultUserName ++ ")")
  66
  67           , Option ['g'] ["group"]
  68                    (ReqArg OptGroupName "GROUP")
  69                    ("Which user to setgid. (default: " ++ defaultGroupName ++ ")")
  70
  71           , Option ['l'] ["log-level"]
  72                    (ReqArg (OptLogLevel . read) "LEVEL")
  73                    ("The lowest log level to show. (default: " ++ show defaultLogLevel ++ ")")
  74
  75           , Option [] ["disable-stderr-log"]
  76                    (NoArg OptDisableStderrLog)
  77                    ("Disable logging to stderr.")
  78
  79           , Option ['h'] ["help"]
  80                    (NoArg OptHelp)
  81                    "Print this message."
  82           ]
  83
  84
  85 printUsage :: IO ()
  86 printUsage = do putStrLn "Usage:"
  87                 putStrLn "  rakka [OPTIONS...]"
  88                 putStrLn ""
  89                 putStr $ usageInfo "Options:" options
  90
  91
  92 main :: IO ()
  93 main = withSubversion $
  94        do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs
  95
  96           when (not $ null errors)
  97                    $ do mapM_ putStr errors
  98                         exitWith $ ExitFailure 1
  99
 100           when (any (\ x -> x == OptHelp) opts)
 101                    $ do printUsage
 102                         exitWith ExitSuccess
 103
 104           when (not $ null nonOpts)
 105                    $ do printUsage
 106                         exitWith $ ExitFailure 1
 107
 108           portNum <- getPortNum opts
 109           uid     <- getUserID  opts
 110           gid     <- getGroupID opts
 111           lsdir   <- getLocalStateDir opts
 112
 113           createLocalStateDir lsdir uid gid
 114
 115           setGroupID gid
 116           setUserID  uid
 117
 118           setupLogger opts
 119           env <- setupEnv lsdir portNum
 120
 121           noticeM logger ("Listening to " ++ show portNum ++ "/tcp...")
 122           runHttpd (envLucuConf env) (resTree env) [fallbackRender env]
 123
 124
 125 resTree :: Environment -> ResTree
 126 resTree env
 127     = mkResTree [ ([]        , resIndex  env)
 128                 , (["object"], resObject env)
 129                 ]
 130
 131
 132 getPortNum :: [CmdOpt] -> IO PortNumber
 133 getPortNum opts
 134     = do let xs = mapMaybe (\ x -> case x of
 135                                      OptPortNum n -> Just n
 136                                      _            -> Nothing) opts
 137          case xs of
 138            []     -> return defaultPort
 139            (x:[]) -> return x
 140            _      -> error "too many --port options."
 141
 142
 143 getUserID :: [CmdOpt] -> IO UserID
 144 getUserID opts
 145     = do let xs   = mapMaybe (\ x -> case x of
 146                                        OptUserName n -> Just n
 147                                        _             -> Nothing) opts
 148              name = case xs of
 149                       []     -> defaultUserName
 150                       (x:[]) -> x
 151                       _      -> error "too many --user options."
 152
 153          userEnt <- getUserEntryForName name
 154          return $ userID userEnt
 155
 156
 157 getGroupID :: [CmdOpt] -> IO GroupID
 158 getGroupID opts
 159     = do let xs   = mapMaybe (\ x -> case x of
 160                                        OptGroupName n -> Just n
 161                                        _              -> Nothing) opts
 162              name = case xs of
 163                       []     -> defaultGroupName
 164                       (x:[]) -> x
 165                       _      -> error "too many --group options."
 166
 167          groupEnt <- getGroupEntryForName name
 168          return $ groupID groupEnt
 169
 170
 171 getLocalStateDir :: [CmdOpt] -> IO FilePath
 172 getLocalStateDir opts
 173     = do let xs   = mapMaybe (\ x -> case x of
 174                                        OptLSDir n -> Just n
 175                                        _          -> Nothing) opts
 176              path = case xs of
 177                       []     -> defaultLocalStateDir
 178                       (x:[]) -> x
 179                       _      -> error "too many --localstatedir options."
 180
 181          return path
 182
 183
 184 setupLogger :: [CmdOpt] -> IO ()
 185 setupLogger opts
 186     = do let disableStderrLog = find (== OptDisableStderrLog) opts /= Nothing
 187              logHandlers      = if disableStderrLog then
 188                                     []
 189                                 else
 190                                     [verboseStreamHandler stderr DEBUG]
 191              logLevel         = fromMaybe defaultLogLevel
 192                                 $ do OptLogLevel l <- find (\ x -> case x of
 193                                                                      OptLogLevel _ -> True
 194                                                                      _             -> False) opts
 195                                      return l
 196
 197          logHandlers' <- sequence logHandlers
 198          updateGlobalLogger rootLoggerName (setHandlers logHandlers' . setLevel logLevel)
 199
 200
 201 createLocalStateDir :: FilePath -> UserID -> GroupID -> IO ()
 202 createLocalStateDir path uid gid
 203     = do createDirectoryIfMissing True path
 204          setOwnerAndGroup path uid gid