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