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 _ = "<Log channel>"
+
+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)