{-# LANGUAGE RecordWildCards, ViewPatterns, TupleSections, PatternGuards #-}
module General.Log(
Log, logCreate, logNone, logAddMessage, logAddEntry,
Summary(..), logSummary,
) where
import Control.Concurrent.Extra
import Control.Applicative
import System.Directory
import System.IO
import Data.Time.Calendar
import Data.Time.Clock
import Numeric.Extra
import Control.Monad.Extra
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Semigroup
import General.Util
import Data.Maybe
import Data.List
import Data.IORef
import Prelude
data Log = Log
{logOutput :: Maybe (Var Handle)
,logCurrent :: IORef (Map.Map Day SummaryI)
,logInteresting :: String -> Bool
}
showTime :: UTCTime -> String
showTime = showUTCTime "%Y-%m-%dT%H:%M:%S%Q"
logNone :: IO Log
logNone = do ref <- newIORef Map.empty; return $ Log Nothing ref (const False)
logCreate :: Either Handle FilePath -> (String -> Bool) -> IO Log
logCreate store interesting = do
(h, old) <- case store of
Left h -> return (h, Map.empty)
Right file -> do
b <- doesFileExist file
mp <- if not b then return Map.empty else withFile file ReadMode $ \h -> do
src <- LBS.hGetContents h
let xs = mapMaybe (parseLogLine interesting) $ LBS.lines src
return $! foldl' (\mp (k,v) -> Map.alter (Just . maybe v (<> v)) k mp) Map.empty xs
(,mp) <$> openFile file AppendMode
hSetBuffering h LineBuffering
var <- newVar h
ref <- newIORef old
return $ Log (Just var) ref interesting
logAddMessage :: Log -> String -> IO ()
logAddMessage Log{..} msg = do
time <- showTime <$> getCurrentTime
whenJust logOutput $ \var -> withVar var $ \h ->
hPutStrLn h $ time ++ " - " ++ msg
logAddEntry :: Log -> String -> String -> Double -> Maybe String -> IO ()
logAddEntry Log{..} user question taken err = do
time <- getCurrentTime
let add v = atomicModifyIORef logCurrent $ \mp -> (Map.alter (Just . maybe v (<> v)) (utctDay time) mp, ())
if logInteresting question then
add $ SummaryI (Set.singleton user) 1 taken (toAverage taken) (if isJust err then 1 else 0)
else if isJust err then
add mempty{iErrors=1}
else
return ()
whenJust logOutput $ \var -> withVar var $ \h ->
hPutStrLn h $ unwords $ [showTime time, user, showDP 3 taken, question] ++
maybeToList (fmap ((++) "ERROR: " . unwords . words) err)
data Summary = Summary
{summaryDate :: Day
,summaryUsers :: Int
,summaryUses :: Int
,summarySlowest :: Double
,summaryAverage :: Double
,summaryErrors :: Int
}
data SummaryI = SummaryI
{iUsers :: !(Set.Set String)
,iUses :: !Int
,iSlowest :: !Double
,iAverage :: !(Average Double)
,iErrors :: !Int
}
instance Semigroup SummaryI where
SummaryI x1 x2 x3 x4 x5 <> SummaryI y1 y2 y3 y4 y5 =
SummaryI (f x1 y1) (x2+y2) (max x3 y3) (x4 <> y4) (x5+y5)
where f x y | Set.size x == 1 = Set.insert (head $ Set.toList x) y
| Set.size y == 1 = Set.insert (head $ Set.toList y) x
| otherwise = Set.union x y
instance Monoid SummaryI where
mempty = SummaryI Set.empty 0 0 (toAverage 0) 0
mappend = (<>)
summarize :: Day -> SummaryI -> Summary
summarize date SummaryI{..} = Summary date (Set.size iUsers) iUses iSlowest (fromAverage iAverage) iErrors
parseLogLine :: (String -> Bool) -> LBS.ByteString -> Maybe (Day, SummaryI)
parseLogLine interesting (LBS.words -> time:user:dur:query:err)
| user /= LBS.pack "-"
, Just [a, b, c] <- fmap (map fst) $ mapM LBS.readInt $ LBS.split '-' $ LBS.takeWhile (/= 'T') time
= Just (fromGregorian (fromIntegral a) b c, SummaryI
(if use then Set.singleton $ LBS.unpack user else Set.empty)
(if use then 1 else 0)
(if use then dur2 else 0)
(toAverage $ if use then dur2 else 0)
(if [LBS.pack "ERROR:"] `isPrefixOf` err then 1 else 0))
where use = interesting $ LBS.unpack query
dur2 = let s = LBS.unpack dur in fromMaybe 0 $
if '.' `elem` s then readMaybe s else (/ 1000) . intToDouble <$> readMaybe s
parseLogLine _ _ = Nothing
logSummary :: Log -> IO [Summary]
logSummary Log{..} = map (uncurry summarize) . Map.toAscList <$> readIORef logCurrent