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