{-# LANGUAGE FlexibleContexts #-}
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 }

-- | This handler simply increases the request counter variable.

hCounter :: PayloadM p Counter m => m Counter
hCounter = payload (modify (Counter . (+1) . unCounter) >> get)

{- |
A simple logger that prints a summery of the request information to the
specified file handle.
-}

hColorLog :: (AddressM' m, MonadIO m, HttpM' m) => Handle -> m ()
hColorLog = logger Nothing

-- | Like `hLog` but also prints the request count since server startup.

hColorLogWithCounter :: (PayloadM p Counter m, AddressM' m, MonadIO m, HttpM' m) => Handle -> m ()
hColorLogWithCounter h = hCounter >>= flip logger h . Just

-- Helper functions.

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