1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Service.Log 3 ( Logs 4 , MonadLog 5 , initLogs 6 , finiLogs 7 , LogStr 8 , toLogStr 9 , requestLog 10 , logMsg 11 , logAccess 12 ) where 13 14 import Control.Monad.IO.Class (MonadIO) 15 import qualified Data.ByteString.Char8 as BSC 16 import Data.Maybe (fromMaybe, catMaybes) 17 import Data.Monoid ((<>)) 18 import Data.Time.Clock (getCurrentTime, diffUTCTime) 19 import Data.Time.Format (formatTime, defaultTimeLocale) 20 import Data.Time.LocalTime (ZonedTime, utcToLocalZonedTime) 21 import qualified Network.HTTP.Types as HTTP 22 import qualified Network.Socket as Net 23 import qualified Network.Wai as Wai 24 import System.Log.FastLogger 25 26 import Databrary.Has (MonadHas) 27 import qualified Databrary.Store.Config as C 28 import Databrary.Model.Time 29 30 data Logs = Logs 31 { loggerMessages, loggerAccess :: Maybe LoggerSet 32 } 33 34 type MonadLog c m = (MonadHas Logs c m, MonadIO m) 35 36 initLog :: FilePath -> C.Config -> IO (Maybe LoggerSet) 37 initLog def conf = do 38 case file of 39 "" -> return Nothing 40 "stdout" -> Just <$> newStdoutLoggerSet buf 41 "stderr" -> Just <$> newStderrLoggerSet buf 42 _ -> do 43 check file 44 mapM_ (rotate . FileLogSpec file size) (num :: Maybe Int) 45 Just <$> newFileLoggerSet buf file 46 where 47 file = fromMaybe def $ conf C.! "file" 48 buf = fromMaybe defaultBufSize $ conf C.! "buf" 49 num = conf C.! "rotate" 50 size = fromMaybe (1024*1024) $ conf C.! "size" 51 52 initLogs :: C.Config -> IO Logs 53 initLogs conf = Logs 54 <$> initLog "stderr" (conf C.! "messages") 55 <*> initLog "stdout" (conf C.! "access") 56 57 finiLogs :: Logs -> IO () 58 finiLogs (Logs lm la) = 59 mapM_ flushLogStr $ catMaybes [lm, la] 60 61 str :: ToLogStr a => a -> LogStr 62 str = toLogStr 63 64 char :: Char -> LogStr 65 char = str . BSC.singleton 66 67 pad :: ToLogStr a => Int -> a -> LogStr 68 pad n m 69 | n < 0 = s <> p 70 | otherwise = p <> s 71 where 72 s = str m 73 p = str $ BSC.replicate (abs n - logStrLength s) ' ' 74 75 quote :: Show a => Maybe a -> LogStr 76 quote = maybe (char '-') (str . show) -- FIXME, inefficient 77 78 time :: ZonedTime -> LogStr 79 time = str . formatTime defaultTimeLocale "%F %X" 80 81 infixr 6 & 82 (&) :: LogStr -> LogStr -> LogStr 83 x & y = x <> char ' ' <> y 84 85 logStr :: LoggerSet -> Timestamp -> LogStr -> IO () 86 logStr l t s = do 87 zt <- utcToLocalZonedTime t 88 pushLogStr l $ time zt & s <> char '\n' 89 90 requestLog :: Timestamp -> Wai.Request -> Maybe String -> Wai.Response -> IO LogStr 91 requestLog qt q u r = do 92 (Just h, Nothing) <- Net.getNameInfo [Net.NI_NUMERICHOST] True False $ Wai.remoteHost q 93 rt <- getCurrentTime 94 return 95 $ pad (-15) h 96 & pad 3 (show $ HTTP.statusCode $ Wai.responseStatus r) 97 & pad 4 (fromMaybe "-" u) 98 & pad 4 (show (floor $ 1000 * rt `diffUTCTime` qt :: Integer)) 99 & str (Wai.requestMethod q) 100 & str (Wai.rawPathInfo q) <> str (Wai.rawQueryString q) 101 & quote (lookup "location" rh) 102 & quote (lookup "referer" qh) 103 & quote (lookup "user-agent" qh) 104 where 105 qh = Wai.requestHeaders q 106 rh = Wai.responseHeaders r 107 108 logMsg :: ToLogStr a => Timestamp -> a -> Logs -> IO () 109 logMsg t m Logs{ loggerMessages = Just l } = do 110 logStr l t $ str m 111 logMsg _ _ _ = return () 112 113 logAccess :: Timestamp -> Wai.Request -> Maybe String -> Wai.Response -> Logs -> IO () 114 logAccess qt q u r Logs{ loggerAccess = Just l } = 115 logStr l qt =<< requestLog qt q u r 116 logAccess _ _ _ _ _ = return ()