Main.hs

   1 {-# LANGUAGE CPP #-}
   2 import           Control.Exception
   3 import           Control.Monad
   4 import           Data.List
   5 import           Data.Maybe
   6 import           Network.Socket
   7 import           Network.HTTP.Lucu
   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.Users
  19 import           Rakka.Storage
  20 import           Subversion
  21 import           System.Console.GetOpt -- FIXME: Use better library than this.
  22 import           System.Directory
  23 import           System.Environment
  24 import           System.Exit
  25 import           System.FilePath
  26 import           System.IO
  27 import           System.Log.Handler.Simple
  28 import           System.Log.Logger
  29 import           System.Posix.Files
  30 import           System.Posix.IO
  31 import           System.Posix.Process
  32 import           System.Posix.Types
  33 import           System.Posix.User
  34
  35
  36 logger :: String
  37 logger = "Main"
  38
  39
  40 data CmdOpt
  41     = OptPortNum   ServiceName
  42     | OptLSDir     FilePath
  43     | OptUserName  String
  44     | OptGroupName String
  45     | OptLogLevel  Priority
  46     | OptVerbose
  47     | OptRebuildIndex
  48     | OptHelp
  49     deriving (Eq, Show)
  50
  51
  52 defaultPort :: ServiceName
  53 defaultPort = "8080"
  54
  55 defaultLocalStateDir :: FilePath
  56 defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP
  57
  58 defaultUserName :: String
  59 defaultUserName = "daemon"
  60
  61 defaultGroupName :: String
  62 defaultGroupName = "daemon"
  63
  64
  65 defaultLogLevel :: Priority
  66 defaultLogLevel = NOTICE
  67
  68
  69 options :: [OptDescr CmdOpt]
  70 options = [ Option ['p'] ["port"]
  71                    (ReqArg OptPortNum "NUM")
  72                    ("Port number to listen. (default: " ++ defaultPort ++ ")")
  73
  74           , Option ['d'] ["localstatedir"]
  75                    (ReqArg OptLSDir "DIR")
  76                    ("Path to the database directory. (default: " ++ defaultLocalStateDir ++ ")")
  77
  78           , Option ['u'] ["user"]
  79                    (ReqArg OptUserName "USER")
  80                    ("Which user to setuid. (default: " ++ defaultUserName ++ ")")
  81
  82           , Option ['g'] ["group"]
  83                    (ReqArg OptGroupName "GROUP")
  84                    ("Which user to setgid. (default: " ++ defaultGroupName ++ ")")
  85
  86           , Option ['l'] ["log-level"]
  87                    (ReqArg (OptLogLevel . read) "LEVEL")
  88                    ("The lowest log level to show. (default: " ++ show defaultLogLevel ++ ")")
  89
  90           , Option ['v'] ["verbose"]
  91                    (NoArg OptVerbose)
  92                    "Enable logging to stderr."
  93
  94           , Option ['r'] ["rebuild-index"]
  95                    (NoArg OptRebuildIndex)
  96                    "Rebuild the index database. (Only for debug purposes)"
  97
  98           , Option ['h'] ["help"]
  99                    (NoArg OptHelp)
 100                    "Print this message."
 101           ]
 102
 103
 104 printUsage :: IO ()
 105 printUsage = do putStrLn "Usage:"
 106                 putStrLn "  rakka [OPTIONS...]"
 107                 putStrLn ""
 108                 putStr $ usageInfo "Options:" options
 109
 110
 111 main :: IO ()
 112 main = withOpenSSL $
 113        withSubversion $
 114        do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs
 115
 116           unless (null errors)
 117                    $ do mapM_ putStr errors
 118                         exitWith $ ExitFailure 1
 119
 120           when (any (\ x -> x == OptHelp) opts)
 121                    $ do printUsage
 122                         exitWith ExitSuccess
 123
 124           unless (null nonOpts)
 125                    $ do printUsage
 126                         exitWith $ ExitFailure 1
 127
 128           portNum <- getPortNum opts
 129           uid     <- getUserID  opts
 130           gid     <- getGroupID opts
 131           lsdir   <- getLocalStateDir opts
 132
 133           -- Create our localstatedir *before* dropping privileges.
 134           createLocalStateDir lsdir uid gid
 135
 136           setGroupID gid
 137           setUserID  uid
 138
 139           -- Now that we have our localstatedir. Let's acquire a lock
 140           -- on the lockfile. Then create other files.
 141           withSystemLock (lsdir </> "lock") $
 142             withPidFile (lsdir </> "pid") $
 143               do setupLogger opts
 144                  env <- setupEnv lsdir portNum
 145
 146                  rebuildIndexIfRequested env opts
 147
 148                  infoM logger ("Listening to " ++ show portNum ++ "/tcp...")
 149                  runHttpd (envLucuConf env) (resTree env) [fallbackPageEntity env]
 150
 151
 152 resTree :: Environment -> ResTree
 153 resTree env
 154     = mkResTree [ ([]              , resIndex        env)
 155                 , (["checkAuth"   ], resCheckAuth    env)
 156                 , (["dumpRepos"   ], resDumpRepos    env)
 157                 , (["js"          ], javaScript         )
 158                 , (["object"      ], resObject       env)
 159                 , (["render"      ], resRender       env)
 160                 , (["search"      ], resSearch       env)
 161                 , (["search.html" ], resSearch       env)
 162                 , (["search.xml"  ], resSearch       env)
 163                 , (["systemConfig"], resSystemConfig env)
 164                 -- , (["trackback"   ], resTrackBack    env)
 165                 , (["users"       ], resUsers        env)
 166                 ]
 167
 168
 169 getPortNum :: [CmdOpt] -> IO ServiceName
 170 getPortNum opts
 171     = do let xs = mapMaybe (\ x -> case x of
 172                                      OptPortNum n -> Just n
 173                                      _            -> Nothing) opts
 174          case xs of
 175            []     -> return defaultPort
 176            (x:[]) -> return x
 177            _      -> error "too many --port options."
 178
 179
 180 getUserID :: [CmdOpt] -> IO UserID
 181 getUserID opts
 182     = do let xs   = mapMaybe (\ x -> case x of
 183                                        OptUserName n -> Just n
 184                                        _             -> Nothing) opts
 185              name = case xs of
 186                       []     -> defaultUserName
 187                       (x:[]) -> x
 188                       _      -> error "too many --user options."
 189
 190          userEnt <- getUserEntryForName name
 191          return $ userID userEnt
 192
 193
 194 getGroupID :: [CmdOpt] -> IO GroupID
 195 getGroupID opts
 196     = do let xs   = mapMaybe (\ x -> case x of
 197                                        OptGroupName n -> Just n
 198                                        _              -> Nothing) opts
 199              name = case xs of
 200                       []     -> defaultGroupName
 201                       (x:[]) -> x
 202                       _      -> error "too many --group options."
 203
 204          groupEnt <- getGroupEntryForName name
 205          return $ groupID groupEnt
 206
 207
 208 getLocalStateDir :: [CmdOpt] -> IO FilePath
 209 getLocalStateDir opts
 210     = do let xs   = mapMaybe (\ x -> case x of
 211                                        OptLSDir n -> Just n
 212                                        _          -> Nothing) opts
 213              path = case xs of
 214                       []     -> defaultLocalStateDir
 215                       (x:[]) -> x
 216                       _      -> error "too many --localstatedir options."
 217
 218          return path
 219
 220
 221 setupLogger :: [CmdOpt] -> IO ()
 222 setupLogger opts
 223     = do let verbose     = find (== OptVerbose) opts /= Nothing
 224              logHandlers = if verbose then
 225                                [verboseStreamHandler stderr DEBUG]
 226                            else
 227                                [] -- FIXME: enable file log
 228              logLevel    = fromMaybe defaultLogLevel
 229                            $ do OptLogLevel l <- find (\ x -> case x of
 230                                                                 OptLogLevel _ -> True
 231                                                                 _             -> False) opts
 232                                 return l
 233
 234          logHandlers' <- sequence logHandlers
 235          updateGlobalLogger rootLoggerName (setHandlers logHandlers' . setLevel logLevel)
 236
 237
 238 createLocalStateDir :: FilePath -> UserID -> GroupID -> IO ()
 239 createLocalStateDir path uid gid
 240     = do createDirectoryIfMissing True path
 241          setOwnerAndGroup path uid gid
 242
 243
 244 rebuildIndexIfRequested :: Environment -> [CmdOpt] -> IO ()
 245 rebuildIndexIfRequested env opts
 246     = do let rebuild = isJust $ find (\ x -> case x of
 247                                                OptRebuildIndex -> True
 248                                                _               -> False) opts
 249          when rebuild
 250                   $ rebuildIndex (envStorage env)
 251
 252 withSystemLock :: FilePath -> IO a -> IO a
 253 withSystemLock lockfile = bracket lock' unlock' . const
 254     where
 255       lock' :: IO Fd
 256       lock' = do fd <- openFd
 257                        lockfile
 258                        ReadWrite
 259                        (Just 420) -- 0644, -rw-r--r--
 260                        defaultFileFlags
 261                  setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 262                  return fd
 263
 264       unlock' :: Fd -> IO ()
 265       unlock' = closeFd
 266
 267 withPidFile :: FilePath -> IO a -> IO a
 268 withPidFile lockfile = bracket_ mkPid' delPid'
 269     where
 270       mkPid' :: IO ()
 271       mkPid' = withFile lockfile WriteMode $ \ h ->
 272                do pid <- getProcessID
 273                   hPutStrLn h (show pid)
 274
 275       delPid' :: IO ()
 276       delPid' = removeFile lockfile