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