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