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