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