{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.FastLogger
( Logger
, timestampedLogEntry
, combinedLogEntry
, newLogger
, newLoggerWithCustomErrorFunction
, withLogger
, withLoggerWithCustomErrorFunction
, stopLogger
, logMsg
) where
import Control.Concurrent (MVar, ThreadId, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar, withMVar)
import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs)
import Control.Exception (AsyncException, Handler (..), IOException, SomeException, bracket, catch, catches, mask_)
import Control.Monad (unless, void, when)
import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString, toLazyByteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Monoid (mappend, mconcat, mempty)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word (Word64)
import Prelude (Eq (..), FilePath, IO, Int, Maybe, Monad (..), Num (..), Ord (..), Show (..), mapM_, maybe, ($), ($!), (++), (.), (||))
import System.IO (IOMode (AppendMode), hClose, hFlush, openFile, stderr, stdout)
import System.PosixCompat.Time (epochTime)
import Snap.Internal.Http.Server.Common (atomicModifyIORef')
import Snap.Internal.Http.Server.Date (getLogDateString)
data Logger = Logger
{ Logger -> IORef Builder
_queuedMessages :: !(IORef Builder)
, Logger -> MVar ()
_dataWaiting :: !(MVar ())
, Logger -> FilePath
_loggerPath :: !(FilePath)
, Logger -> MVar ThreadId
_loggingThread :: !(MVar ThreadId)
, Logger -> StrictByteString -> IO ()
_errAction :: ByteString -> IO ()
}
newLogger :: FilePath
-> IO Logger
newLogger :: FilePath -> IO Logger
newLogger = (StrictByteString -> IO ()) -> FilePath -> IO Logger
newLoggerWithCustomErrorFunction
(\StrictByteString
s -> Handle -> StrictByteString -> IO ()
S.hPutStr Handle
stderr StrictByteString
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr)
newLoggerWithCustomErrorFunction :: (ByteString -> IO ())
-> FilePath
-> IO Logger
newLoggerWithCustomErrorFunction :: (StrictByteString -> IO ()) -> FilePath -> IO Logger
newLoggerWithCustomErrorFunction StrictByteString -> IO ()
errAction FilePath
fp = do
IORef Builder
q <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
MVar ()
dw <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ThreadId
th <- IO (MVar ThreadId)
forall a. IO (MVar a)
newEmptyMVar
let lg :: Logger
lg = IORef Builder
-> MVar ()
-> FilePath
-> MVar ThreadId
-> (StrictByteString -> IO ())
-> Logger
Logger IORef Builder
q MVar ()
dw FilePath
fp MVar ThreadId
th StrictByteString -> IO ()
errAction
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ThreadId
tid <- StrictByteString
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOLabeledWithUnmaskBs StrictByteString
"snap-server: logging" (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
Logger -> (forall a. IO a -> IO a) -> IO ()
loggingThread Logger
lg
MVar ThreadId -> ThreadId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ThreadId
th ThreadId
tid
Logger -> IO Logger
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Logger
lg
withLogger :: FilePath
-> (Logger -> IO a)
-> IO a
withLogger :: forall a. FilePath -> (Logger -> IO a) -> IO a
withLogger FilePath
f = IO Logger -> (Logger -> IO ()) -> (Logger -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IO Logger
newLogger FilePath
f) Logger -> IO ()
stopLogger
withLoggerWithCustomErrorFunction :: (ByteString -> IO ())
-> FilePath
-> (Logger -> IO a)
-> IO a
withLoggerWithCustomErrorFunction :: forall a.
(StrictByteString -> IO ()) -> FilePath -> (Logger -> IO a) -> IO a
withLoggerWithCustomErrorFunction StrictByteString -> IO ()
e FilePath
f =
IO Logger -> (Logger -> IO ()) -> (Logger -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((StrictByteString -> IO ()) -> FilePath -> IO Logger
newLoggerWithCustomErrorFunction StrictByteString -> IO ()
e FilePath
f) Logger -> IO ()
stopLogger
timestampedLogEntry :: ByteString -> IO ByteString
timestampedLogEntry :: StrictByteString -> IO StrictByteString
timestampedLogEntry StrictByteString
msg = do
StrictByteString
timeStr <- IO StrictByteString
getLogDateString
StrictByteString -> IO StrictByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString -> IO StrictByteString)
-> StrictByteString -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$! [StrictByteString] -> StrictByteString
S.concat
([StrictByteString] -> StrictByteString)
-> [StrictByteString] -> StrictByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> [StrictByteString]
L.toChunks
(LazyByteString -> [StrictByteString])
-> LazyByteString -> [StrictByteString]
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
toLazyByteString
(Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Char -> Builder
char8 Char
'['
, StrictByteString -> Builder
byteString StrictByteString
timeStr
, StrictByteString -> Builder
byteString StrictByteString
"] "
, StrictByteString -> Builder
byteString StrictByteString
msg ]
combinedLogEntry :: ByteString
-> Maybe ByteString
-> ByteString
-> Int
-> Word64
-> Maybe ByteString
-> ByteString
-> IO ByteString
combinedLogEntry :: StrictByteString
-> Maybe StrictByteString
-> StrictByteString
-> Int
-> Word64
-> Maybe StrictByteString
-> StrictByteString
-> IO StrictByteString
combinedLogEntry !StrictByteString
host !Maybe StrictByteString
mbUser !StrictByteString
req !Int
status !Word64
numBytes !Maybe StrictByteString
mbReferer !StrictByteString
ua = do
StrictByteString
timeStr <- IO StrictByteString
getLogDateString
let !l :: [Builder]
l = [ StrictByteString -> Builder
byteString StrictByteString
host
, StrictByteString -> Builder
byteString StrictByteString
" - "
, Builder
user
, StrictByteString -> Builder
byteString StrictByteString
" ["
, StrictByteString -> Builder
byteString StrictByteString
timeStr
, StrictByteString -> Builder
byteString StrictByteString
"] \""
, StrictByteString -> Builder
byteString StrictByteString
req
, StrictByteString -> Builder
byteString StrictByteString
"\" "
, Int -> Builder
forall a. Show a => a -> Builder
fromShow Int
status
, Builder
space
, Word64 -> Builder
forall a. Show a => a -> Builder
fromShow Word64
numBytes
, Builder
space
, Builder
referer
, StrictByteString -> Builder
byteString StrictByteString
" \""
, StrictByteString -> Builder
byteString StrictByteString
ua
, Builder
quote ]
StrictByteString -> IO StrictByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString -> IO StrictByteString)
-> StrictByteString -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$! [StrictByteString] -> StrictByteString
S.concat ([StrictByteString] -> StrictByteString)
-> (LazyByteString -> [StrictByteString])
-> LazyByteString
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> [StrictByteString]
L.toChunks (LazyByteString -> StrictByteString)
-> LazyByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString) -> Builder -> LazyByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
l
where
dash :: Builder
dash = Char -> Builder
char8 Char
'-'
quote :: Builder
quote = Char -> Builder
char8 Char
'\"'
space :: Builder
space = Char -> Builder
char8 Char
' '
user :: Builder
user = Builder
-> (StrictByteString -> Builder)
-> Maybe StrictByteString
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
dash StrictByteString -> Builder
byteString Maybe StrictByteString
mbUser
referer :: Builder
referer = Builder
-> (StrictByteString -> Builder)
-> Maybe StrictByteString
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
dash
(\StrictByteString
s -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Builder
quote
, StrictByteString -> Builder
byteString StrictByteString
s
, Builder
quote ])
Maybe StrictByteString
mbReferer
logMsg :: Logger -> ByteString -> IO ()
logMsg :: Logger -> StrictByteString -> IO ()
logMsg !Logger
lg !StrictByteString
s = do
let !s' :: Builder
s' = StrictByteString -> Builder
byteString StrictByteString
s Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
'\n'
IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Logger -> IORef Builder
_queuedMessages Logger
lg) ((Builder -> (Builder, ())) -> IO ())
-> (Builder -> (Builder, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Builder
d -> (Builder
d Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
s',())
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (Logger -> MVar ()
_dataWaiting Logger
lg) ()
loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO ()
loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO ()
loggingThread (Logger IORef Builder
queue MVar ()
notifier FilePath
filePath MVar ThreadId
_ StrictByteString -> IO ()
errAct) forall a. IO a -> IO a
unmask = do
IO (IORef Handle, IORef EpochTime)
initialize IO (IORef Handle, IORef EpochTime)
-> ((IORef Handle, IORef EpochTime) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IORef Handle, IORef EpochTime) -> IO ()
go
where
openIt :: IO Handle
openIt =
if FilePath
filePath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"-"
then Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
else
if FilePath
filePath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"stderr"
then Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stderr
else FilePath -> IOMode -> IO Handle
openFile FilePath
filePath IOMode
AppendMode IO Handle -> (IOException -> IO Handle) -> IO Handle
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
\(IOException
e::IOException) -> do
FilePath -> IO ()
logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Can't open log file \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\".\n"
FilePath -> IO ()
logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Exception: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
FilePath -> IO ()
logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Logging to stderr instead. " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
"**THIS IS BAD, YOU OUGHT TO " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
"FIX THIS**\n\n"
Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stderr
closeIt :: Handle -> IO ()
closeIt Handle
h = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Handle
h Handle -> Handle -> Bool
forall a. Eq a => a -> a -> Bool
== Handle
stdout Bool -> Bool -> Bool
|| Handle
h Handle -> Handle -> Bool
forall a. Eq a => a -> a -> Bool
== Handle
stderr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> IO ()
hClose Handle
h
logInternalError :: FilePath -> IO ()
logInternalError = StrictByteString -> IO ()
errAct (StrictByteString -> IO ())
-> (FilePath -> StrictByteString) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> StrictByteString
T.encodeUtf8 (Text -> StrictByteString)
-> (FilePath -> Text) -> FilePath -> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
go :: (IORef Handle, IORef EpochTime) -> IO ()
go (IORef Handle
href, IORef EpochTime
lastOpened) = IO () -> IO ()
forall a. IO a -> IO a
unmask IO ()
forall {b}. IO b
loop IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches`
[ (AsyncException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((AsyncException -> IO ()) -> Handler ())
-> (AsyncException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(AsyncException
_::AsyncException) -> (IORef Handle, IORef EpochTime) -> IO ()
killit (IORef Handle
href, IORef EpochTime
lastOpened)
, (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO ()) -> Handler ())
-> (SomeException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e::SomeException) -> do
FilePath -> IO ()
logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"logger got exception: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
Prelude.show SomeException
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
Int -> IO ()
threadDelay Int
20000000
(IORef Handle, IORef EpochTime) -> IO ()
go (IORef Handle
href, IORef EpochTime
lastOpened) ]
where
loop :: IO b
loop = (IORef Handle, IORef EpochTime) -> IO ()
waitFlushDelay (IORef Handle
href, IORef EpochTime
lastOpened) IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
loop
initialize :: IO (IORef Handle, IORef EpochTime)
initialize = do
Handle
lh <- IO Handle
openIt
IORef Handle
href <- Handle -> IO (IORef Handle)
forall a. a -> IO (IORef a)
newIORef Handle
lh
EpochTime
t <- IO EpochTime
epochTime
IORef EpochTime
tref <- EpochTime -> IO (IORef EpochTime)
forall a. a -> IO (IORef a)
newIORef EpochTime
t
(IORef Handle, IORef EpochTime)
-> IO (IORef Handle, IORef EpochTime)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef Handle
href, IORef EpochTime
tref)
killit :: (IORef Handle, IORef EpochTime) -> IO ()
killit (IORef Handle
href, IORef EpochTime
lastOpened) = do
(IORef Handle, IORef EpochTime) -> IO ()
flushIt (IORef Handle
href, IORef EpochTime
lastOpened)
Handle
h <- IORef Handle -> IO Handle
forall a. IORef a -> IO a
readIORef IORef Handle
href
Handle -> IO ()
closeIt Handle
h
flushIt :: (IORef Handle, IORef EpochTime) -> IO ()
flushIt (!IORef Handle
href, !IORef EpochTime
lastOpened) = do
Builder
dl <- IORef Builder -> (Builder -> (Builder, Builder)) -> IO Builder
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Builder
queue ((Builder -> (Builder, Builder)) -> IO Builder)
-> (Builder -> (Builder, Builder)) -> IO Builder
forall a b. (a -> b) -> a -> b
$ \Builder
x -> (Builder
forall a. Monoid a => a
mempty,Builder
x)
let !msgs :: LazyByteString
msgs = Builder -> LazyByteString
toLazyByteString Builder
dl
Handle
h <- IORef Handle -> IO Handle
forall a. IORef a -> IO a
readIORef IORef Handle
href
(do Handle -> LazyByteString -> IO ()
L.hPut Handle
h LazyByteString
msgs
Handle -> IO ()
hFlush Handle
h) IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e::IOException) -> do
FilePath -> IO ()
logInternalError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"got exception writing to log " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
FilePath -> IO ()
logInternalError FilePath
"writing log entries to stderr.\n"
(StrictByteString -> IO ()) -> [StrictByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StrictByteString -> IO ()
errAct ([StrictByteString] -> IO ()) -> [StrictByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ LazyByteString -> [StrictByteString]
L.toChunks LazyByteString
msgs
EpochTime
t <- IO EpochTime
epochTime
EpochTime
old <- IORef EpochTime -> IO EpochTime
forall a. IORef a -> IO a
readIORef IORef EpochTime
lastOpened
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EpochTime
tEpochTime -> EpochTime -> EpochTime
forall a. Num a => a -> a -> a
-EpochTime
old EpochTime -> EpochTime -> Bool
forall a. Ord a => a -> a -> Bool
> EpochTime
900) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
closeIt Handle
h
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Handle
openIt IO Handle -> (Handle -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Handle -> Handle -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Handle
href
IORef EpochTime -> EpochTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef EpochTime
lastOpened EpochTime
t
waitFlushDelay :: (IORef Handle, IORef EpochTime) -> IO ()
waitFlushDelay !(IORef Handle, IORef EpochTime)
d = do
()
_ <- MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
notifier
(IORef Handle, IORef EpochTime) -> IO ()
flushIt (IORef Handle, IORef EpochTime)
d
Int -> IO ()
threadDelay Int
5000000
stopLogger :: Logger -> IO ()
stopLogger :: Logger -> IO ()
stopLogger Logger
lg = MVar ThreadId -> (ThreadId -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Logger -> MVar ThreadId
_loggingThread Logger
lg) ThreadId -> IO ()
killThread
fromShow :: Show a => a -> Builder
fromShow :: forall a. Show a => a -> Builder
fromShow = FilePath -> Builder
stringUtf8 (FilePath -> Builder) -> (a -> FilePath) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show