X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Main.hs;h=3df4d8b23a910a86ce895238dac27e26c0e9cf4d;hp=df2cccb5a17ccfd5e37835adb22eeba0c3f709d3;hb=HEAD;hpb=790089d18791029ad268b3306ca71f8d5ae44ce1 diff --git a/Main.hs b/Main.hs index df2cccb..3df4d8b 100644 --- a/Main.hs +++ b/Main.hs @@ -1,31 +1,60 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE + CPP + , UnicodeSyntax + #-} +import Control.Exception import Control.Monad +import Data.List import Data.Maybe -import Network +import Network.Socket import Network.HTTP.Lucu +import OpenSSL import Rakka.Environment +import Rakka.Resource.CheckAuth +import Rakka.Resource.DumpRepos import Rakka.Resource.Index +import Rakka.Resource.JavaScript +import Rakka.Resource.PageEntity import Rakka.Resource.Object -import Rakka.Resource.Page -import System.Console.GetOpt +import Rakka.Resource.Render +import Rakka.Resource.Search +import Rakka.Resource.SystemConfig +import Rakka.Resource.Users +import Rakka.Storage +import Subversion +import System.Console.GetOpt -- FIXME: Use better library than this. import System.Directory import System.Environment import System.Exit +import System.FilePath +import System.IO +import System.Log.Handler.Simple +import System.Log.Logger import System.Posix.Files +import System.Posix.IO +import System.Posix.Process import System.Posix.Types import System.Posix.User + +logger :: String +logger = "Main" + + data CmdOpt - = OptPortNum PortNumber + = OptPortNum ServiceName | OptLSDir FilePath | OptUserName String | OptGroupName String + | OptLogLevel Priority + | OptVerbose + | OptRebuildIndex | OptHelp deriving (Eq, Show) -defaultPort :: PortNumber -defaultPort = fromIntegral 8080 +defaultPort ∷ ServiceName +defaultPort = "8080" defaultLocalStateDir :: FilePath defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP @@ -37,10 +66,14 @@ defaultGroupName :: String defaultGroupName = "daemon" +defaultLogLevel :: Priority +defaultLogLevel = NOTICE + + options :: [OptDescr CmdOpt] options = [ Option ['p'] ["port"] - (ReqArg (OptPortNum . fromIntegral . read) "NUM") - ("Port number to listen. (default: " ++ show defaultPort ++ ")") + (ReqArg OptPortNum "NUM") + ("Port number to listen. (default: " ++ defaultPort ++ ")") , Option ['d'] ["localstatedir"] (ReqArg OptLSDir "DIR") @@ -54,6 +87,18 @@ options = [ Option ['p'] ["port"] (ReqArg OptGroupName "GROUP") ("Which user to setgid. (default: " ++ defaultGroupName ++ ")") + , Option ['l'] ["log-level"] + (ReqArg (OptLogLevel . read) "LEVEL") + ("The lowest log level to show. (default: " ++ show defaultLogLevel ++ ")") + + , Option ['v'] ["verbose"] + (NoArg OptVerbose) + "Enable logging to stderr." + + , Option ['r'] ["rebuild-index"] + (NoArg OptRebuildIndex) + "Rebuild the index database. (Only for debug purposes)" + , Option ['h'] ["help"] (NoArg OptHelp) "Print this message." @@ -68,9 +113,11 @@ printUsage = do putStrLn "Usage:" main :: IO () -main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs +main = withOpenSSL $ + withSubversion $ + do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs - when (not $ null errors) + unless (null errors) $ do mapM_ putStr errors exitWith $ ExitFailure 1 @@ -78,7 +125,7 @@ main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs $ do printUsage exitWith ExitSuccess - when (not $ null nonOpts) + unless (null nonOpts) $ do printUsage exitWith $ ExitFailure 1 @@ -87,32 +134,49 @@ main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs gid <- getGroupID opts lsdir <- getLocalStateDir opts + -- Create our localstatedir *before* dropping privileges. createLocalStateDir lsdir uid gid setGroupID gid setUserID uid - env <- setupEnv lsdir portNum - runHttpd (envLucuConf env) (resTree env) [fallbackPage env] + -- Now that we have our localstatedir. Let's acquire a lock + -- on the lockfile. Then create other files. + withSystemLock (lsdir "lock") $ + withPidFile (lsdir "pid") $ + do setupLogger opts + env ← setupEnv lsdir portNum + + rebuildIndexIfRequested env opts + + infoM logger ("Listening to " ++ show portNum ++ "/tcp...") + runHttpd (envLucuConf env) (resTree env) [fallbackPageEntity env] resTree :: Environment -> ResTree resTree env - = mkResTree [ ([] , resIndex env) - , (["object"], resObject env) + = mkResTree [ ([] , resIndex env) + , (["checkAuth" ], resCheckAuth env) + , (["dumpRepos" ], resDumpRepos env) + , (["js" ], javaScript ) + , (["object" ], resObject env) + , (["render" ], resRender env) + , (["search" ], resSearch env) + , (["search.html" ], resSearch env) + , (["search.xml" ], resSearch env) + , (["systemConfig"], resSystemConfig env) + , (["users" ], resUsers env) ] - -getPortNum :: [CmdOpt] -> IO PortNumber +getPortNum ∷ [CmdOpt] → IO ServiceName getPortNum opts - = do let xs = mapMaybe (\ x -> case x of - OptPortNum n -> Just n - _ -> Nothing) opts + = do let xs = mapMaybe (\x → case x of + OptPortNum n → Just n + _ → Nothing) opts case xs of - [] -> return defaultPort - (x:[]) -> return x - _ -> error "too many --port options." - + [] → return defaultPort + (x:[]) → return x + _ → error "too many --port options." getUserID :: [CmdOpt] -> IO UserID getUserID opts @@ -155,7 +219,59 @@ getLocalStateDir opts return path +setupLogger :: [CmdOpt] -> IO () +setupLogger opts + = do let verbose = find (== OptVerbose) opts /= Nothing + logHandlers = if verbose then + [verboseStreamHandler stderr DEBUG] + else + [] -- FIXME: enable file log + logLevel = fromMaybe defaultLogLevel + $ do OptLogLevel l <- find (\ x -> case x of + OptLogLevel _ -> True + _ -> False) opts + return l + + logHandlers' <- sequence logHandlers + updateGlobalLogger rootLoggerName (setHandlers logHandlers' . setLevel logLevel) + + createLocalStateDir :: FilePath -> UserID -> GroupID -> IO () createLocalStateDir path uid gid = do createDirectoryIfMissing True path setOwnerAndGroup path uid gid + + +rebuildIndexIfRequested :: Environment -> [CmdOpt] -> IO () +rebuildIndexIfRequested env opts + = do let rebuild = isJust $ find (\ x -> case x of + OptRebuildIndex -> True + _ -> False) opts + when rebuild + $ rebuildIndex (envStorage env) + +withSystemLock :: FilePath -> IO a -> IO a +withSystemLock lockfile = bracket lock' unlock' . const + where + lock' :: IO Fd + lock' = do fd <- openFd + lockfile + ReadWrite + (Just 420) -- 0644, -rw-r--r-- + defaultFileFlags + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + return fd + + unlock' :: Fd -> IO () + unlock' = closeFd + +withPidFile :: FilePath -> IO a -> IO a +withPidFile lockfile = bracket_ mkPid' delPid' + where + mkPid' :: IO () + mkPid' = withFile lockfile WriteMode $ \ h -> + do pid <- getProcessID + hPutStrLn h (show pid) + + delPid' :: IO () + delPid' = removeFile lockfile