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