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 ()