diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Change Log +## [0.0.3 -- 2019-05-06] + +### Added + +- MonadCaster for ReaderT pattern. + ## [0.0.2 -- 2019-05-04] ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -76,8 +76,9 @@ The logger requires to be given `LogQueue`, so functions which log need to take `LogQueue` as a parameter. -You can inject `LogQueue` with Reader Monad and so on, -but I recommend to use easily [Data\.Reflection](https://hackage.haskell.org/package/reflection). +You can inject `LogQueue` with Reader Monad and so on. +`System.Log.Caster.Monad` provides `MonadCaster` for ReaderT patteren. +Another way, you can use [Data\.Reflection](https://hackage.haskell.org/package/reflection). ```haskell diff --git a/caster.cabal b/caster.cabal --- a/caster.cabal +++ b/caster.cabal @@ -1,5 +1,5 @@ name: caster -version: 0.0.2.1 +version: 0.0.3.0 synopsis: Multicast, thread-safe, and fast logger. description: Please see the README on GitHub at homepage: https://github.com/kirisaki/caster#readme @@ -20,6 +20,8 @@ library exposed-modules: System.Log.Caster + , System.Log.Caster.Core + , System.Log.Caster.Monad build-depends: base >= 4.10 , bytestring >= 0.10.8.2 , fast-builder >= 0.1.0.0 @@ -45,11 +47,13 @@ hs-source-dirs: test default-extensions: LambdaCase + , FlexibleInstances build-depends: base >= 4 && < 5 , caster , bytestring , directory + , mtl , text , fast-builder , QuickCheck diff --git a/src/System/Log/Caster.hs b/src/System/Log/Caster.hs --- a/src/System/Log/Caster.hs +++ b/src/System/Log/Caster.hs @@ -7,7 +7,6 @@ Maintainer : Akihito KIRISAKI Stability : experimental -} -{-# LANGUAGE UndecidableInstances #-} module System.Log.Caster ( -- * Basics LogMsg(..) @@ -28,6 +27,7 @@ -- * Formatter , defaultFormatter , terminalFormatter + , terminalFormatterWith -- * Log levels , LogLevel(..) , logAs @@ -46,195 +46,11 @@ , (<:>) ) where +import System.Log.Caster.Core import Control.Concurrent.STM -import Control.Monad -import Control.Monad.IO.Class (MonadIO (..)) -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.FastBuilder as FB -import qualified Data.ByteString.Lazy as LBS -import Data.Semigroup -import qualified Data.Text as ST -import qualified Data.Text.Encoding as STE -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LTE -import Data.UnixTime (Format, UnixTime (..), - formatUnixTime, getUnixTime) -import GHC.IO.Unsafe (unsafePerformIO) -import System.IO (Handle, hFlush, stdout) - --- | Types which are able to be converted into @'FB.Builder' Builder@ --- @toBuilde@ encodes @String@ and @Text@ as utf-8. -class ToBuilder a where - toBuilder :: a -> FB.Builder - -instance ToBuilder FB.Builder where - toBuilder = id - -instance ToBuilder String where - toBuilder = FB.stringUtf8 - -instance ToBuilder ST.Text where - toBuilder = FB.byteString . STE.encodeUtf8 - -instance ToBuilder LT.Text where - toBuilder = FB.byteString . LBS.toStrict . LTE.encodeUtf8 - -instance ToBuilder SBS.ByteString where - toBuilder = FB.byteString - -instance ToBuilder LBS.ByteString where - toBuilder = FB.byteString . LBS.toStrict - -instance ToBuilder BB.Builder where - toBuilder = FB.byteString . LBS.toStrict . BB.toLazyByteString - -instance {-# OVERLAPPABLE #-} Show a => ToBuilder a where - toBuilder = FB.stringUtf8 . show - --- | If you turn @OverloadedStrings@ extension on, GHC can't deduce the type of string literal. --- This function fix the type to @'FB.Builder' Builder@ without type annotation. -fix :: FB.Builder -> FB.Builder -fix = id - --- | Infix version of @fix@. -infixr 0 $: -($:) :: ToBuilder b => (FB.Builder -> b) -> FB.Builder -> b -($:) = ($) - --- | Concat @ToBuilder@ strings as @'FB.Builder' Builder@. -infixr 6 <:> -(<:>) :: (ToBuilder a, ToBuilder b) => a -> b -> FB.Builder -a <:> b = toBuilder a <> toBuilder b - --- |Log levels. These are matched to syslog. -data LogLevel - = LogDebug - | LogInfo - | LogNotice - | LogWarn - | LogError - | LogCritical - | LogAlert - | LogEmergency - deriving (Show, Eq, Ord) - --- | Log message. -data LogMsg = LogMsg - { logMsgLevel :: LogLevel - , logMsgTime :: UnixTime - , logMsgBuilder :: FB.Builder - } - --- | Queue of @LogMsg@. -newtype LogQueue = LogQueue (TQueue LogMsg) - --- | Channel of @LogMsg@. -newtype LogChan = LogChan (TChan LogMsg) - --- | Make new @LogQueue@ -newLogQueue :: IO LogQueue -newLogQueue = LogQueue <$> newTQueueIO - --- | Make new @LogChan@. -newLogChan :: IO LogChan -newLogChan = LogChan <$> newBroadcastTChanIO - --- | Connect @LogQueue@ and @TChan@ @LogMsg@. -broadcastLog :: LogQueue -> LogChan -> IO () -broadcastLog (LogQueue q) (LogChan c) = forever $ - atomically $ readTQueue q >>= writeTChan c - --- | Formatter. -type Formatter = LogMsg -> FB.Builder - --- | IO function takes @LogMsg@. -type Listener = LogMsg -> IO () - --- | Listen @LogChan@ and give the @LogMsg@ to given @Listener@. -relayLog :: LogChan -> LogLevel -> Listener -> IO () -relayLog (LogChan bchan) logLevel listener = do - chan <- atomically $ dupTChan bchan - forever $ do - msg <- atomically $ readTChan chan - when (logMsgLevel msg >= logLevel) $ listener msg - --- | Make @Listener@ from @Handle@ -handleListener :: Formatter -> Handle -> Listener -handleListener f h = FB.hPutBuilder h . f - --- | Make @Listener@ flushing buffer after getting @LogMsg@ -handleListenerFlush :: Formatter -> Handle -> Listener -handleListenerFlush f h msg = FB.hPutBuilder h (f msg) >> hFlush h - --- | Stdout listener with @Formatter@. -stdoutListenerWith :: Formatter -> Listener -stdoutListenerWith f = handleListenerFlush f stdout - --- | Stdout listener. -stdoutListener :: Listener -stdoutListener = stdoutListenerWith defaultFormatter - --- | Terminal listener. Log levels are colored. -terminalListener :: Listener -terminalListener = stdoutListenerWith terminalFormatter - --- | Default log formatter. -defaultFormatter :: Formatter -defaultFormatter (LogMsg lev ut str) = - formatTime ut <> " - [" <> logLevelToBuilder lev <> "] " <> str <> "\n" - --- | Formatter for term. --- It provides colored logs. -terminalFormatter :: Formatter -terminalFormatter = terminalFormatterWith - "\ESC[32m" - "\ESC[36m" - "\ESC[4m\ESC[36m" - "\ESC[4m\ESC[33m" - "\ESC[4m\ESC[31m" - "\ESC[1m\ESC[31m" - "\ESC[1m\ESC[35m" - "\ESC[5m\ESC[35m" - --- | Formatter with specified colors for log levels. --- Parameters are just @FB.Builder@, so you can decorate as you like with ansi escaping. -terminalFormatterWith :: FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> Formatter -terminalFormatterWith fDebug fInfo fNotice fWarn fError fCritical fAlert fEmergency (LogMsg lev ut str) = - formatTime ut <> " - " <> fmt <> "[" <> logLevelToBuilder lev <> "]\ESC[0m " <> str <> "\n" - where - fmt = case lev of - LogDebug -> fDebug - LogInfo -> fInfo - LogNotice -> fNotice - LogWarn -> fWarn - LogError -> fError - LogCritical -> fCritical - LogAlert -> fAlert - LogEmergency -> fEmergency - - -logLevelToBuilder :: LogLevel -> FB.Builder -logLevelToBuilder = \case - LogDebug -> "DEBUG" - LogInfo -> "INFO" - LogNotice -> "NOTICE" - LogWarn -> "WARN" - LogError -> "ERROR" - LogCritical -> "CRITICAL" - LogAlert -> "ALERT" - LogEmergency -> "EMERGENCY" - - -{-# NOINLINE formatTime #-} -formatTime :: UnixTime -> FB.Builder -formatTime ut = - let - ut' = FB.byteString . unsafePerformIO $ formatUnixTime "%Y-%m-%d %T" ut - utMilli = FB.string7 . tail . show $ utMicroSeconds ut `div` 1000 + 1000 - in - ut' <> "." <> utMilli +import Control.Monad.IO.Class (MonadIO (..)) +import Data.UnixTime (getUnixTime) -- | Push a message to @LogQueue@. logAs :: (MonadIO m, ToBuilder s) => LogQueue -> LogLevel -> s -> m () diff --git a/src/System/Log/Caster/Core.hs b/src/System/Log/Caster/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Caster/Core.hs @@ -0,0 +1,227 @@ +{-| +Module : System.Log.Caster.Core +Description : Multicast, thread-safe, and not slow logger. +Copyright : (c) Akihito KIRISAKI + +License : BSD3 +Maintainer : Akihito KIRISAKI +Stability : experimental +-} +{-# LANGUAGE UndecidableInstances #-} +module System.Log.Caster.Core + ( -- * Basics + LogMsg(..) + , broadcastLog + , LogQueue(..) + , newLogQueue + , LogChan(..) + , newLogChan + , Formatter + , Listener + , relayLog + -- * Listeners + , stdoutListener + , stdoutListenerWith + , terminalListener + , handleListener + , handleListenerFlush + -- * Formatter + , defaultFormatter + , terminalFormatter + , terminalFormatterWith + -- * Log levels + , LogLevel(..) + -- * Useful string class and operator + , ToBuilder(..) + , fix + , ($:) + , (<:>) + ) where + +import Control.Concurrent.STM +import Control.Monad +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.FastBuilder as FB +import qualified Data.ByteString.Lazy as LBS +import Data.Semigroup +import qualified Data.Text as ST +import qualified Data.Text.Encoding as STE +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LTE +import Data.UnixTime (Format, UnixTime (..), + formatUnixTime) +import GHC.IO.Unsafe (unsafePerformIO) +import System.IO (Handle, hFlush, stdout) + +-- | Types which are able to be converted into @'FB.Builder' Builder@ +-- @toBuilde@ encodes @String@ and @Text@ as utf-8. +class ToBuilder a where + toBuilder :: a -> FB.Builder + +instance ToBuilder FB.Builder where + toBuilder = id + +instance ToBuilder String where + toBuilder = FB.stringUtf8 + +instance ToBuilder ST.Text where + toBuilder = FB.byteString . STE.encodeUtf8 + +instance ToBuilder LT.Text where + toBuilder = FB.byteString . LBS.toStrict . LTE.encodeUtf8 + +instance ToBuilder SBS.ByteString where + toBuilder = FB.byteString + +instance ToBuilder LBS.ByteString where + toBuilder = FB.byteString . LBS.toStrict + +instance ToBuilder BB.Builder where + toBuilder = FB.byteString . LBS.toStrict . BB.toLazyByteString + +instance {-# OVERLAPPABLE #-} Show a => ToBuilder a where + toBuilder = FB.stringUtf8 . show + +-- | If you turn @OverloadedStrings@ extension on, GHC can't deduce the type of string literal. +-- This function fix the type to @'FB.Builder' Builder@ without type annotation. +fix :: FB.Builder -> FB.Builder +fix = id + +-- | Infix version of @fix@. +infixr 0 $: +($:) :: ToBuilder b => (FB.Builder -> b) -> FB.Builder -> b +($:) = ($) + +-- | Concat @ToBuilder@ strings as @'FB.Builder' Builder@. +infixr 6 <:> +(<:>) :: (ToBuilder a, ToBuilder b) => a -> b -> FB.Builder +a <:> b = toBuilder a <> toBuilder b + +-- |Log levels. These are matched to syslog. +data LogLevel + = LogDebug + | LogInfo + | LogNotice + | LogWarn + | LogError + | LogCritical + | LogAlert + | LogEmergency + deriving (Show, Eq, Ord) + +-- | Log message. +data LogMsg = LogMsg + { logMsgLevel :: LogLevel + , logMsgTime :: UnixTime + , logMsgBuilder :: FB.Builder + } + +-- | Queue of @LogMsg@. +newtype LogQueue = LogQueue (TQueue LogMsg) + +-- | Channel of @LogMsg@. +newtype LogChan = LogChan (TChan LogMsg) + +-- | Make new @LogQueue@ +newLogQueue :: IO LogQueue +newLogQueue = LogQueue <$> newTQueueIO + +-- | Make new @LogChan@. +newLogChan :: IO LogChan +newLogChan = LogChan <$> newBroadcastTChanIO + +-- | Connect @LogQueue@ and @TChan@ @LogMsg@. +broadcastLog :: LogQueue -> LogChan -> IO () +broadcastLog (LogQueue q) (LogChan c) = forever $ + atomically $ readTQueue q >>= writeTChan c + +-- | Formatter. +type Formatter = LogMsg -> FB.Builder + +-- | IO function takes @LogMsg@. +type Listener = LogMsg -> IO () + +-- | Listen @LogChan@ and give the @LogMsg@ to given @Listener@. +relayLog :: LogChan -> LogLevel -> Listener -> IO () +relayLog (LogChan bchan) logLevel listener = do + chan <- atomically $ dupTChan bchan + forever $ do + msg <- atomically $ readTChan chan + when (logMsgLevel msg >= logLevel) $ listener msg + +-- | Make @Listener@ from @Handle@ +handleListener :: Formatter -> Handle -> Listener +handleListener f h = FB.hPutBuilder h . f + +-- | Make @Listener@ flushing buffer after getting @LogMsg@ +handleListenerFlush :: Formatter -> Handle -> Listener +handleListenerFlush f h msg = FB.hPutBuilder h (f msg) >> hFlush h + +-- | Stdout listener with @Formatter@. +stdoutListenerWith :: Formatter -> Listener +stdoutListenerWith f = handleListenerFlush f stdout + +-- | Stdout listener. +stdoutListener :: Listener +stdoutListener = stdoutListenerWith defaultFormatter + +-- | Terminal listener. Log levels are colored. +terminalListener :: Listener +terminalListener = stdoutListenerWith terminalFormatter + +-- | Default log formatter. +defaultFormatter :: Formatter +defaultFormatter (LogMsg lev ut str) = + formatTime ut <> " - [" <> logLevelToBuilder lev <> "] " <> str <> "\n" + +-- | Formatter for term. +-- It provides colored logs. +terminalFormatter :: Formatter +terminalFormatter = terminalFormatterWith + "\ESC[32m" + "\ESC[36m" + "\ESC[4m\ESC[36m" + "\ESC[4m\ESC[33m" + "\ESC[4m\ESC[31m" + "\ESC[1m\ESC[31m" + "\ESC[1m\ESC[35m" + "\ESC[5m\ESC[35m" + +-- | Formatter with specified colors for log levels. +-- Parameters are just @FB.Builder@, so you can decorate as you like with ansi escaping. +terminalFormatterWith :: FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> FB.Builder -> Formatter +terminalFormatterWith fDebug fInfo fNotice fWarn fError fCritical fAlert fEmergency (LogMsg lev ut str) = + formatTime ut <> " - " <> fmt <> "[" <> logLevelToBuilder lev <> "]\ESC[0m " <> str <> "\n" + where + fmt = case lev of + LogDebug -> fDebug + LogInfo -> fInfo + LogNotice -> fNotice + LogWarn -> fWarn + LogError -> fError + LogCritical -> fCritical + LogAlert -> fAlert + LogEmergency -> fEmergency + + +logLevelToBuilder :: LogLevel -> FB.Builder +logLevelToBuilder = \case + LogDebug -> "DEBUG" + LogInfo -> "INFO" + LogNotice -> "NOTICE" + LogWarn -> "WARN" + LogError -> "ERROR" + LogCritical -> "CRITICAL" + LogAlert -> "ALERT" + LogEmergency -> "EMERGENCY" + + +{-# NOINLINE formatTime #-} +formatTime :: UnixTime -> FB.Builder +formatTime ut = + let + ut' = FB.byteString . unsafePerformIO $ formatUnixTime "%Y-%m-%d %T" ut + utMilli = FB.string7 . tail . show $ utMicroSeconds ut `div` 1000 + 1000 + in + ut' <> "." <> utMilli diff --git a/src/System/Log/Caster/Monad.hs b/src/System/Log/Caster/Monad.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Caster/Monad.hs @@ -0,0 +1,79 @@ +{-| +Module : System.Log.Caster.Monad +Description : Multicast, thread-safe, and not slow logger. +Copyright : (c) Akihito KIRISAKI + +License : BSD3 +Maintainer : Akihito KIRISAKI +Stability : experimental +-} +module System.Log.Caster.Monad + ( -- * Basics + LogMsg(..) + , broadcastLog + , LogQueue(..) + , newLogQueue + , LogChan(..) + , newLogChan + , Formatter + , Listener + , relayLog + -- * Listeners + , stdoutListener + , stdoutListenerWith + , terminalListener + , handleListener + , handleListenerFlush + -- * Formatter + , defaultFormatter + , terminalFormatter + , terminalFormatterWith + -- * Log levels + , LogLevel(..) + , MonadCaster(..) + -- * Useful string class and operator + , ToBuilder(..) + , fix + , ($:) + , (<:>) + ) where + +import System.Log.Caster.Core + +import Control.Concurrent.STM +import Control.Monad.IO.Class (MonadIO (..)) +import Data.UnixTime (getUnixTime) + +-- | Logging monad for ReaderT pattern. +class MonadIO m => MonadCaster m where + getLogQueue :: m LogQueue + + logAs :: ToBuilder s => LogLevel -> s -> m () + logAs l s = do + ut <- liftIO getUnixTime + LogQueue q <- getLogQueue + liftIO . atomically $ writeTQueue q (LogMsg l ut (toBuilder s)) + + debug :: ToBuilder s => s -> m () + debug = logAs LogDebug + + info :: ToBuilder s => s -> m () + info = logAs LogInfo + + notice :: ToBuilder s => s -> m () + notice = logAs LogNotice + + warn :: ToBuilder s => s -> m () + warn = logAs LogWarn + + err :: ToBuilder s => s -> m () + err = logAs LogError + + critical :: ToBuilder s => s -> m () + critical = logAs LogCritical + + alert :: ToBuilder s => s -> m () + alert = logAs LogAlert + + emergency :: ToBuilder s => s -> m () + emergency = logAs LogEmergency diff --git a/test/CasterTest.hs b/test/CasterTest.hs --- a/test/CasterTest.hs +++ b/test/CasterTest.hs @@ -2,6 +2,8 @@ module CasterTest where import System.Log.Caster +import qualified System.Log.Caster.Monad as CM + import Test.QuickCheck.Instances import Test.QuickCheck.Monadic as QCM import Test.Tasty @@ -11,6 +13,8 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Control.Monad.Reader (MonadReader (..), ReaderT, + runReaderT) import qualified Data.ByteString as SBS import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.FastBuilder as FB @@ -121,4 +125,27 @@ threadDelay 100000 killThread thread0 killThread threadb + + +instance CM.MonadCaster (ReaderT LogQueue IO) where + getLogQueue = ask + +unit_monad :: IO () +unit_monad = do + chan <- newLogChan + lq <- newLogQueue + thread0 <- forkIO $ relayLog chan LogDebug stdoutListener + flip runReaderT lq $ do + CM.debug "mona" + CM.info "mona" + CM.notice "mona" + CM.warn "mona" + CM.err "mona" + CM.critical "mona" + CM.alert "mona" + CM.emergency "mona" + threadb <- forkIO $ broadcastLog lq chan + threadDelay 100001 + killThread threadb + killThread thread0