{-# 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 -> ByteString -> IO ()
_errAction :: ByteString -> IO ()
}
newLogger :: FilePath
-> IO Logger
newLogger :: FilePath -> IO Logger
newLogger = (ByteString -> IO ()) -> FilePath -> IO Logger
newLoggerWithCustomErrorFunction
(\ByteString
s -> Handle -> ByteString -> IO ()
S.hPutStr Handle
stderr ByteString
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr)
newLoggerWithCustomErrorFunction :: (ByteString -> IO ())
-> FilePath
-> IO Logger
newLoggerWithCustomErrorFunction :: (ByteString -> IO ()) -> FilePath -> IO Logger
newLoggerWithCustomErrorFunction ByteString -> 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
-> (ByteString -> IO ())
-> Logger
Logger IORef Builder
q MVar ()
dw FilePath
fp MVar ThreadId
th ByteString -> 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 <- ByteString -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOLabeledWithUnmaskBs ByteString
"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 (m :: * -> *) a. Monad m => a -> m a
return Logger
lg
withLogger :: FilePath
-> (Logger -> IO a)
-> IO a
withLogger :: 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 :: (ByteString -> IO ()) -> FilePath -> (Logger -> IO a) -> IO a
withLoggerWithCustomErrorFunction ByteString -> 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 ((ByteString -> IO ()) -> FilePath -> IO Logger
newLoggerWithCustomErrorFunction ByteString -> IO ()
e FilePath
f) Logger -> IO ()
stopLogger
timestampedLogEntry :: ByteString -> IO ByteString
timestampedLogEntry :: ByteString -> IO ByteString
timestampedLogEntry ByteString
msg = do
ByteString
timeStr <- IO ByteString
getLogDateString
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat
([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks
(ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString
(Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Char -> Builder
char8 Char
'['
, ByteString -> Builder
byteString ByteString
timeStr
, ByteString -> Builder
byteString ByteString
"] "
, ByteString -> Builder
byteString ByteString
msg ]
combinedLogEntry :: ByteString
-> Maybe ByteString
-> ByteString
-> Int
-> Word64
-> Maybe ByteString
-> ByteString
-> IO ByteString
combinedLogEntry :: ByteString
-> Maybe ByteString
-> ByteString
-> Int
-> Word64
-> Maybe ByteString
-> ByteString
-> IO ByteString
combinedLogEntry !ByteString
host !Maybe ByteString
mbUser !ByteString
req !Int
status !Word64
numBytes !Maybe ByteString
mbReferer !ByteString
ua = do
ByteString
timeStr <- IO ByteString
getLogDateString
let !l :: [Builder]
l = [ ByteString -> Builder
byteString ByteString
host
, ByteString -> Builder
byteString ByteString
" - "
, Builder
user
, ByteString -> Builder
byteString ByteString
" ["
, ByteString -> Builder
byteString ByteString
timeStr
, ByteString -> Builder
byteString ByteString
"] \""
, ByteString -> Builder
byteString ByteString
req
, ByteString -> Builder
byteString ByteString
"\" "
, 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
, ByteString -> Builder
byteString ByteString
" \""
, ByteString -> Builder
byteString ByteString
ua
, Builder
quote ]
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
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 -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
dash ByteString -> Builder
byteString Maybe ByteString
mbUser
referer :: Builder
referer = Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
dash
(\ByteString
s -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Builder
quote
, ByteString -> Builder
byteString ByteString
s
, Builder
quote ])
Maybe ByteString
mbReferer
logMsg :: Logger -> ByteString -> IO ()
logMsg :: Logger -> ByteString -> IO ()
logMsg !Logger
lg !ByteString
s = do
let !s' :: Builder
s' = ByteString -> Builder
byteString ByteString
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
_ ByteString -> 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 (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 (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 (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 (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 = ByteString -> IO ()
errAct (ByteString -> IO ())
-> (FilePath -> ByteString) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
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 (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 (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 :: ByteString
msgs = Builder -> ByteString
toLazyByteString Builder
dl
Handle
h <- IORef Handle -> IO Handle
forall a. IORef a -> IO a
readIORef IORef Handle
href
(do Handle -> ByteString -> IO ()
L.hPut Handle
h ByteString
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"
(ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
errAct ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
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 (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 :: 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