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