module Network.Salvia.Handler.ColorLog
( Counter (..)
, hCounter
, hColorLog
, hColorLogWithCounter
)
where
import Control.Applicative
import Control.Monad.State
import Data.List
import Data.Record.Label hiding (get)
import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
import Network.Protocol.Http
import Network.Salvia.Interface
import System.IO
import System.Locale
import Util.Terminal
newtype Counter = Counter { unCounter :: Integer }
hCounter :: PayloadM p Counter m => m Counter
hCounter = payload (modify (Counter . (+1) . unCounter) >> get)
hColorLog :: (AddressM' m, MonadIO m, HttpM' m) => Handle -> m ()
hColorLog = logger Nothing
hColorLogWithCounter :: (PayloadM p Counter m, AddressM' m, MonadIO m, HttpM' m) => Handle -> m ()
hColorLogWithCounter h = hCounter >>= flip logger h . Just
logger :: (AddressM' m, MonadIO m, HttpM' m) => Maybe Counter -> Handle -> m ()
logger mcount h =
do let count = maybe "-" (show . unCounter) mcount
mt <- request (getM method)
ur <- request (getM uri)
st <- response (getM status)
ca <- clientAddress
sa <- serverAddress
dt <- liftIO $
do zone <- getCurrentTimeZone
time <- utcToLocalTime zone <$> getCurrentTime
return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" time
liftIO
. hPutStrLn h
$ intercalate " ; "
[ dt
, show sa
, count
, methodToColor mt ++ show mt ++ reset
, show ca
, whiteBold ++ ur ++ reset
, statusToColor st ++ show (codeFromStatus st) ++
" " ++ show st ++ reset
]
statusToColor :: Status -> String
statusToColor st =
case codeFromStatus st of
c | c <= 199 -> blueBold
| c <= 299 -> greenBold
| c <= 399 -> yellowBold
| c <= 499 -> redBold
_ -> magentaBold
methodToColor :: Method -> String
methodToColor GET = whiteBold
methodToColor _ = yellowBold