From a9ad795991d4a2bbfe199a8dc6fcd328a7f0b6e6 Mon Sep 17 00:00:00 2001 From: portnov Date: Sun, 5 Jul 2009 23:41:05 +0600 Subject: [PATCH] Add logging support --- Blog/Config.hs | 1 - Framework/API.hs | 12 ++++++- Framework/Http/HTTPServer.hs | 23 +++++++++++--- Framework/Logger.hs | 70 ++++++++++++++++++++++++++++++++++++++++++ Framework/Types.hs | 7 ++-- 5 files changed, 103 insertions(+), 10 deletions(-) create mode 100644 Framework/Logger.hs diff --git a/Blog/Config.hs b/Blog/Config.hs index c84c5fa..f1bac60 100644 --- a/Blog/Config.hs +++ b/Blog/Config.hs @@ -4,7 +4,6 @@ import System.IO import Framework.Types params = HP { docdir = "static", - hLog = stdout, -- dbDriver = "sqlite3", dbDriver = "psql", -- dbPath = "blog.db", diff --git a/Framework/API.hs b/Framework/API.hs index 3e31ca8..b764c52 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -8,7 +8,8 @@ module Framework.API queryList, queryList', query, query', commit, queryListSQL, queryListSQL', querySQL, querySQL', - getcookie, setcookie + getcookie, setcookie, + accessLog, errorLog )where import Debug.Trace @@ -25,6 +26,7 @@ import qualified Framework.Storage as Storage import qualified Framework.Urls as Urls import qualified Framework.Cache as Cache import qualified Framework.SQL as SQL +import qualified Framework.Logger as Logger import Framework.Models (Model) import Framework.Http.Response ((<+>)) import Framework.Http.HTTPServer (serveHttp,serveStatic) @@ -100,3 +102,11 @@ getcookie ac name = Cookies.getcookie (request ac) name setcookie :: ActionConfig -> String -> String -> HttpHeader setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value +---------------------------------------------------------------------------------------------------------- +-- * Logger API + +accessLog :: ActionConfig -> String -> IO () +accessLog ac msg = Logger.writeLog (logChan $ httpParams ac) (request ac) msg + +errorLog :: ActionConfig -> String -> IO () +errorLog ac msg = Logger.writeLog (errChan $ httpParams ac) (request ac) msg diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index 91b4872..061a9de 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -9,6 +9,7 @@ import System.Posix.Signals import System.Exit import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn) import System.IO.UTF8 +import Control.Concurrent.Chan import Codec.Binary.UTF8.String import System.Directory import Control.Exception @@ -18,6 +19,7 @@ import Network.URI import Framework.Cache import Framework.Storage import Framework.Pool +import Framework.Logger import Framework.Types import Framework.Urls import Framework.Utils @@ -39,7 +41,7 @@ serveStatic ac s = Just $ serveStatic' ac s serveStatic' ac resource = if (reqMethod $ request ac) == "GET" then do --- putStrLn $ "Sending "++filepath + writeLog (logChan $ httpParams ac) (request ac) $ "Sending "++filepath exists <- doesFileExist filepath (toResponse exists) `catch` handleError else return $ response 400 [] "Invalid request method" @@ -47,7 +49,7 @@ serveStatic' ac resource = where handleError :: SomeException -> IO Response handleError e = do - hPutStr (hLog $ httpParams ac) $ show e + writeLog (errChan $ httpParams ac) (request ac) $ show e return $ response 500 [] (show e ++ emptyLine) toResponse False = return $ response 404 [] $ "File "++filepath++" not found!" @@ -73,10 +75,13 @@ defaultURLConf :: URLConf defaultURLConf = Function serveStatic -- freePools :: MPool DBConnection -> MPool CacheConnection -> IO () -freePools dbPool cPool = do +cleanup dbPool cPool hacc herr = do print "Disconnecting from DB and cache" freeAll dbPool disconnect' freeAll cPool cDisconnect + print "Closing logs" + hClose hacc + hClose herr exitWith ExitSuccess -- | Start HTTP server @@ -89,6 +94,14 @@ serveHttp port hap conf = do cPool <- emptyPool 10 garbageCollector dbPool disconnect' garbageCollector cPool cDisconnect --- installHandler sigINT (CatchOnce (freePools dbPool cPool)) Nothing - initServer port (httpWorker (hap {dbpool=dbPool, cpool=cPool}) conf) + aLog <- newChan + eLog <- newChan + hAccess <- openFile "access.log" WriteMode + hErrors <- openFile "errors.log" WriteMode + runLogWriter aLog eLog hAccess hErrors + installHandler sigINT (CatchOnce (cleanup dbPool cPool hAccess hErrors)) Nothing + initServer port (httpWorker (hap {dbpool = dbPool, + cpool = cPool, + logChan = aLog, + errChan = eLog }) conf) diff --git a/Framework/Logger.hs b/Framework/Logger.hs new file mode 100644 index 0000000..695955e --- /dev/null +++ b/Framework/Logger.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module Framework.Logger + (Log, + writeLog, + runLogWriter + ) where + +import Prelude hiding (print,putStrLn) +import System.Time +import System.IO hiding (hPutStrLn,putStrLn,print) +import System.IO.UTF8 +import System.Locale +import Control.Monad +import Control.Concurrent +import Control.Concurrent.Chan +import Text.Printf + +import Network.Shed.Httpd (Request) + +data LogItem = LogItem { + logRequest :: Request, + logTime :: String, + logMessage :: String } + +type Log = Chan LogItem + +instance Show Log where + show _ = "" + +currentTime :: IO String +currentTime = do + time <- getClockTime + ctime <- toCalendarTime time + return $ formatCalendarTime defaultTimeLocale "%c" ctime + +formatMsg :: LogItem -> String +formatMsg item = printf "%s: %s" (logTime item) (logMessage item) + +writeLog :: Log -> Request -> String -> IO () +writeLog chan rq msg = do + time <- currentTime + writeChan chan $ LogItem rq time msg + +runLogWriter :: Log -> Log -> Handle -> Handle -> IO ThreadId +runLogWriter aLog eLog afile efile = forkIO $ do + every 3000000 $ do + flushLog aLog afile + flushLog eLog efile + +flushLog :: Log -> Handle -> IO () +flushLog chan hndl = do + items <- getChanContents chan + forM_ items $ \item -> do +-- putStrLn $ formatMsg item + hPutStrLn hndl $ formatMsg item + hFlush hndl + +untilIO :: IO Bool -> IO a -> IO () +untilIO cond action = do + val <- cond + if val + then return () + else do action + untilIO cond action + +every :: Int -> IO a -> IO b +every ms action = do + action + threadDelay ms + every ms action diff --git a/Framework/Types.hs b/Framework/Types.hs index fb40b5b..02cb49a 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -10,11 +10,11 @@ import qualified Database.HDBC as D import Framework.Http.SessionTypes import Framework.CacheTypes import Framework.Pool +import Framework.Logger ---------------------------------------------------------------- --Types -- -type Channel = Handle type S = String -- | Container type for any database connection @@ -27,7 +27,6 @@ instance Show DBConnection where data StaticConfig = HP { docdir :: String, -- ^ Static content directory - hLog :: Handle, -- ^ Handle to log dbDriver :: String, -- ^ DB backend name dbPath :: String, -- ^ Info for DB backend cacheDriver :: String, -- ^ Cache backend name @@ -35,7 +34,9 @@ data StaticConfig = HP { sessionsDriver :: String, -- ^ Sessions backend name sessionsPath :: String, -- ^ Info for sessions backend dbpool :: MPool DBConnection, -- ^ DB connections pool - cpool :: MPool CacheConnection -- ^ Cache connections pool + cpool :: MPool CacheConnection,-- ^ Cache connections pool + logChan :: Log, -- ^ Handle to log + errChan :: Log -- ^ Handle to errors log } deriving (Show) -- 1.7.2.3