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