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