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