Main.hs

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