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