module Network.Wai.Logging.Buffered (
Config(..),
Event(..),
Publish,
bufferedRequestLogger,
runBufferedRequestLogger
) where
import Control.Concurrent
import Control.Exception (bracket, catch, Exception, SomeException)
import Control.Monad (forever)
import Data.Default (Default(..))
import Data.Foldable (foldl')
import Data.IORef
import Data.Monoid ((<>))
import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime, NominalDiffTime)
import GHC.Exts (toList)
import Network.Wai (Application, Request, Middleware,
rawPathInfo, requestMethod)
import Network.Wai.Internal (Response(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Sequence as S
import qualified Data.Map as M
type Publish = [Event] -> IO ()
data Config = Config {
maxSize :: Int,
publishIntervalSeconds :: Int,
pubFunc :: Publish,
useWildcards :: Bool
}
instance Default Config where
def = Config {
maxSize = 1000,
publishIntervalSeconds = 10,
pubFunc = print,
useWildcards = True
}
data Event = Event {
path:: !BS.ByteString,
reportedTime :: !UTCTime,
duration :: !NominalDiffTime
}
deriving (Show, Eq, Ord)
newtype Buffer = Buffer (S.Seq Event)
deriving (Eq, Ord, Monoid)
buffer :: IORef Buffer
buffer = unsafePerformIO . newIORef $ Buffer S.empty
logEvent ::
Config
-> Request
-> UTCTime
-> IO ()
logEvent (Config {..}) req start = do
finish <- getCurrentTime
let path = rawPathInfo req
event = Event (requestMethod req <>":"<>path) finish (finish `diffUTCTime` start)
(Buffer b) <- readIORef buffer
if S.length b < maxSize
then atomicModifyIORef' buffer $ addToBuffer event
else print $ errorMsg event
where
addToBuffer evt (Buffer ls) = (Buffer (evt S.<| ls), ())
errorMsg ::
Event
-> String
errorMsg Event {..} =
show reportedTime <> " [Error][Logging] Log Buffer Full. Dropping: \n" <>
"\tPath: "<>show path<> ", Duration: "<> show duration
publishBuffer ::
Bool
-> Publish
-> IO ()
publishBuffer useWc doPublish = do
events <- atomicModifyIORef' buffer clearBuffer
let events' = if useWc
then concat . M.elems. M.filterWithKey wcPred $ foldl' applyWildCard M.empty events
else toList events
catch (doPublish events') (preserveAndLog events')
where
wcPred k xs = (length xs > 1 && BSC.any (== '*') k) || BSC.all (/= '*') k
clearBuffer (Buffer ls) = (Buffer S.empty, ls)
mergeBufer events b = (b <> Buffer events, ())
preserveAndLog :: [Event] -> SomeException -> IO ()
preserveAndLog events e = do
atomicModifyIORef' buffer . mergeBufer $ S.fromList events
print e
runBufferedRequestLogger ::
Config
-> IO ()
runBufferedRequestLogger (Config {..}) =
forever $ do
threadDelay $ toMicros publishIntervalSeconds
publishBuffer useWildcards pubFunc
where
toMicros = (*) 1000000
bufferedRequestLogger ::
Config
-> Middleware
bufferedRequestLogger conf app req sendResponse = do
t0 <- getCurrentTime
app req $ \res -> do
x <- case res of
ResponseRaw{} -> pure ()
_ -> pure ()
logEvent conf req t0
sendResponse res
applyWildCard ::
M.Map BS.ByteString [Event]
-> Event
-> M.Map BS.ByteString [Event]
applyWildCard known e =
foldl' accum known $ setPath <$> wildCardPermutations (path e)
where
accum m evt = M.insertWith (<>) (path evt) [evt] m
setPath p = e {path = p}
wildCardPermutations ::
BS.ByteString
-> [BS.ByteString]
wildCardPermutations "" = []
wildCardPermutations path = let
segments = BSC.split '/' path
wildcarded = perms segments
res = BS.intercalate "/" <$> wildcarded
in res
where
replaceAt :: [BS.ByteString] -> Int -> [BS.ByteString]
replaceAt bs n = case Prelude.splitAt n bs of
(as, []) -> as
(as, b:bs) -> as <> ("*":bs)
perms :: [BS.ByteString] -> [[BS.ByteString]]
perms xs = replaceAt xs <$> [0.. Prelude.length xs]