From: pho <pho@cielonegro.org>
Date: Tue, 23 Oct 2007 06:33:17 +0000 (+0900)
Subject: Added basic logging facility: it needs a fix later
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=0b1235464affca4fb349c713278d2e37fd8e9584;p=Rakka.git

Added basic logging facility: it needs a fix later

darcs-hash:20071023063317-62b54-b5e49722759603b45acff683cfc7bea57eff1d47.gz
---

diff --git a/Main.hs b/Main.hs
index 4485568..5ce9eb1 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 import           Control.Monad
+import           Data.List
 import           Data.Maybe
 import           Network
 import           Network.HTTP.Lucu
@@ -12,16 +13,23 @@ import           System.Console.GetOpt
 import           System.Directory
 import           System.Environment
 import           System.Exit
+import           System.IO
+import           System.Log.Handler.Simple
+import           System.Log.Logger
 import           System.Posix.Files
 import           System.Posix.Types
 import           System.Posix.User
 
+logger = "Main"
+
 
 data CmdOpt
     = OptPortNum   PortNumber
     | OptLSDir     FilePath
     | OptUserName  String
     | OptGroupName String
+    | OptLogLevel  Priority
+    | OptDisableStderrLog
     | OptHelp
     deriving (Eq, Show)
 
@@ -39,6 +47,10 @@ defaultGroupName :: String
 defaultGroupName = "daemon"
 
 
+defaultLogLevel :: Priority
+defaultLogLevel = NOTICE
+
+
 options :: [OptDescr CmdOpt]
 options = [ Option ['p'] ["port"]
                    (ReqArg (OptPortNum . fromIntegral . read) "NUM")
@@ -56,6 +68,14 @@ 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 [] ["disable-stderr-log"]
+                   (NoArg OptDisableStderrLog)
+                   ("Disable logging to stderr.")
+
           , Option ['h'] ["help"]
                    (NoArg OptHelp)
                    "Print this message."
@@ -95,7 +115,10 @@ main = withSubversion $
           setGroupID gid
           setUserID  uid
 
-          env     <- setupEnv lsdir portNum
+          setupLogger opts
+          env <- setupEnv lsdir portNum
+
+          noticeM logger ("Listening to " ++ show portNum ++ "/tcp...")
           runHttpd (envLucuConf env) (resTree env) [fallbackRender env]
 
           
@@ -158,6 +181,23 @@ getLocalStateDir opts
          return path
 
 
+setupLogger :: [CmdOpt] -> IO ()
+setupLogger opts
+    = do let disableStderrLog = find (== OptDisableStderrLog) opts /= Nothing
+             logHandlers      = if disableStderrLog then
+                                    []
+                                else
+                                    [verboseStreamHandler stderr DEBUG]
+             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
diff --git a/Rakka.cabal b/Rakka.cabal
index 844381b..2a546d8 100644
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -25,8 +25,8 @@ Extensions:
 GHC-Options:
     -fwarn-unused-imports -fglasgow-exts
 Build-Depends:
-    Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hxt, mtl,
-    network, parsec, stm, unix
+    Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hslogger,
+    hxt, mtl, network, parsec, stm, unix
 Exposed-Modules:
     Rakka.Page
     Rakka.Storage
diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs
index b554df8..6ae6f11 100644
--- a/Rakka/Environment.hs
+++ b/Rakka/Environment.hs
@@ -20,6 +20,9 @@ import           Rakka.Wiki.Interpreter.Base
 import           Subversion.Repository
 import           System.Directory
 import           System.FilePath
+import           System.Log.Logger
+
+logger = "Rakka.Environment"
 
 
 data Environment = Environment {
@@ -45,9 +48,11 @@ setupEnv lsdir portNum
          
          reposExist  <- doesDirectoryExist reposPath
          repos       <- if reposExist then
-                            openRepository reposPath
+                            do debugM logger ("Found a subversion repository on " ++ reposPath)
+                               openRepository reposPath
                         else
-                            createRepository reposPath [] []
+                            do noticeM logger ("Creating a subversion repository on " ++ reposPath)
+                               createRepository reposPath [] []
          sysConf     <- mkSystemConfig lucuConf repos
          interpTable <- mkInterpTable
 
diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index 8a6be02..58de2be 100644
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -28,6 +28,9 @@ import           Subversion.FileSystem.Revision
 import           Subversion.FileSystem.Root
 import           Subversion.Repository
 import           System.FilePath.Posix
+import           System.Log.Logger
+
+logger = "Rakka.SystemConfig"
 
 
 data SystemConfig = SystemConfig {
@@ -72,20 +75,28 @@ getSysConf sc key
 
 getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
 getSysConf' sc key
-    = do fs    <- getRepositoryFS (scRepository sc)
+    = do let path = fromConfPath (sysConfPath key)
+
+         fs    <- getRepositoryFS (scRepository sc)
          rev   <- getYoungestRev fs
          value <- withRevision fs rev
-                  $ do let path = fromConfPath (sysConfPath key)
-                       exists <- isFile path
+                  $ do exists <- isFile path
                        case exists of
                          True
                              -> do str <- getFileContentsLBS path
                                    return $ Just $ chomp $ decodeLazy UTF8 str
                          False
                              -> return Nothing
+
          case value of
-           Just str -> return $ unmarshalSysConf key str
-           Nothing  -> sysConfDefault sc key
+           Just str
+               -> do let val = unmarshalSysConf key str
+                     debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
+                     return val
+           Nothing
+               -> do val <- sysConfDefault sc key
+                     debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
+                     return val
 
 
 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue