packages feed

caster (empty) → 0.0.1.0

raw patch · 8 files changed

+536/−0 lines, 8 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, caster, directory, fast-builder, quickcheck-instances, stm, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, text, unix-time

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Change Log++## [0.0.1 -- 2019-04-13]++### Added++- Basic functions.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2019, Akihito KIRISAKI+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,114 @@+# caster+caster is a multicast, thread-safe and fast logger.+It's convenient when log towards multiple outputs, +for example, when you want to log to stdout and files same time.+It's possible to change format and log level each outputs.+Also, it converts text-like values and Show instances into log messages automatically.++## Usage++First, the logger requires concurrency.++```haskell+import Control.Concurrent+```++Then, prepare to use the logger. +In following code, make `LogQueue`, `LogChan` and `Listener`,+start threads which relay messages from `LogChan` to the outputs +and one which broadcasts messages to `LogChan`.+Be careful not to change the order of `relayLog` and `broadcastLog`.+It causes that messages at the first are not logged correctly.++```haskell+import System.IO+import System.Log.Caster++main = do+  chan <- newLogChan+  lq <- newLogQueue++  -- log to a file..+  handle <- openFile "./foo.log" "caster_test_0.log"+  let FileListener = handleListener defaultFormatter handle+  _ <- forkIO $ relayLog chan LogDebug fileListener++  -- log to stdout.+  _ <- forkIO $ relayLog chan LogInfo stdoutListener++  -- start to broadcast.+  _ <- forkIO $ broadcastLog lq chan+  +  -- give the LogQueue to the function which you want to log in.+  someFunc lq++```++Last, push a message into the `LogQueue` with given functions in order to log.++``` haskell++someFunc :: LogQueue -> IO ()+someFunc lq = do++  -- log levels are matched to syslog.+  -- if you use OverloadedStrings, need to add type annotation.+  debug lq ("debug message" :: String)+  +  -- or you can use helper operator or helper function.+  info lq $: "info messages"+  info lq $ fix  "info messages"+  +  -- if the type is obviously, need not to annotate.+  let msg = Data.Text.pack "notice message"+  notice lq msg+  +  -- it's possible to give incetanse of Show.+  warn lq True+  +  -- there is the useful operator which concatrates text-like values.+  -- the values are converted into byte string as utf-8.+  let text = "foo" :: Data.Text.Text+  let bs = "bar" :: Data.ByteString.Lazy.ByteString+  err lq $ text <:> bs <:> fix "baz"+  +```++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).+++```haskell+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE RankNTypes                #-}++import Control.Concurrent+import Control.Monad+import Data.Reflection+import System.Log.Caster++type UseLogger = Given LogQueue++useLogger :: UseLogger => LogQueue+useLogger = given++someIO :: UseLogger => IO ()+someIO = do+  critical useLogger "critical message"+  alert useLogger "alert message"+  emergency useLogger "..."+  +inject :: (UseLogger => a) -> IO a+inject io = do+  lq <- newLogQueue+  give io lq+  +main :: IO ()+main = do+  chan <- newLogChan+  _ <- forkIO $ relayLog chan LogDebug stdoutListener+  join $ inject someIO+  +```
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ caster.cabal view
@@ -0,0 +1,60 @@+name:                caster+version:             0.0.1.0+synopsis:            Multicast, thread-safe, and fast logger.+description:         Please see the README on GitHub at <https://github.com/kirisaki/caster#readme>+homepage:            https://github.com/kirisaki/caster#readme+bug-reports:         https://github.com/kirisaki/caster/issues+license:             BSD3+license-file:        LICENSE+author:              Akihito KIRISAKI+maintainer:          kirisaki@klaraworks.net+copyright:           Akihito KIRISAKI+category:            System+build-type:          Simple+extra-source-files:  CHANGELOG.md, README.md+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/kirisaki/caster++library+  exposed-modules: System.Log.Caster+  -- other-extensions:+  build-depends:       base >= 4.10+                     , bytestring >= 0.10.8.2+                     , fast-builder >= 0.1.0.0+                     , stm >= 2.5.0.0+                     , text >= 1.2.3.1+                     , unix-time >= 0.4.5+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions: LambdaCase+                    , OverloadedStrings+                    , FlexibleInstances+                    , FlexibleContexts+                    , TypeSynonymInstances+                    , MultiParamTypeClasses+                    , ExistentialQuantification++test-suite test+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+                CasterTest+  default-language:    Haskell2010+  hs-source-dirs:+                 test+  build-depends:+                base >= 4 && < 5+              , caster+              , bytestring+              , directory+              , text+              , fast-builder+              , QuickCheck+              , quickcheck-instances+              , tasty-hunit+              , tasty+              , tasty-discover+              , tasty-quickcheck
+ src/System/Log/Caster.hs view
@@ -0,0 +1,231 @@+{-|+Module      : System.Log.Caster+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+  ( -- * Basics+    LogMsg(..)+  , broadcastLog+  , LogQueue(..)+  , newLogQueue+  , LogChan(..)+  , newLogChan+  , Formatter+  , Listener+  , relayLog+  -- * Listeners+  , stdoutListener+  , stdoutListenerWith+  , handleListener+  , handleListenerFlush+  -- * Formatter+  , defaultFormatter+  -- * Log levels+  , LogLevel(..)+  , logAs+  , debug+  , info+  , notice+  , warn+  , err+  , critical+  , alert+  , emergency+  -- * Useful string class and operator+  , ToBuilder(..)+  , fix+  , ($:)+  , (<:>)+  ) where+++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+++-- | Default log formatter.+defaultFormatter :: Formatter+defaultFormatter (LogMsg lev ut str) =+  formatTime ut <> " - [" <> logLevelToBuilder lev <> "] " <> str <> "\n"++logLevelToBuilder :: LogLevel -> FB.Builder+logLevelToBuilder = \case+  LogDebug -> "DEBUG"+  LogInfo  -> "INFO"+  LogNotice  -> "NOTICE"+  LogWarn  -> "WARN"+  LogError -> "ERROR"+  LogCritical -> "CRITICAL"+  LogAlert -> "ALERT"+  LogEmergency -> "EMERGEBCY"++{-# 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++-- | Push a message to @LogQueue@.+logAs :: (MonadIO m, ToBuilder s) => LogQueue -> LogLevel -> s -> m ()+logAs (LogQueue q) l s = liftIO $ do+  ut <- getUnixTime+  atomically $ writeTQueue q (LogMsg l ut (toBuilder s))++debug :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+debug q = logAs q LogDebug++info :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+info q = logAs q LogInfo++notice :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+notice q = logAs q LogNotice++warn :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+warn q = logAs q LogWarn++err :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+err q = logAs q LogError++critical :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+critical q = logAs q LogCritical++alert :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+alert q = logAs q LogAlert++emergency :: (MonadIO m, ToBuilder s) => LogQueue -> s -> m ()+emergency q = logAs q LogEmergency
+ test/CasterTest.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE BangPatterns #-}+module CasterTest where++import           System.Log.Caster+import           Test.QuickCheck.Instances+import           Test.QuickCheck.Monadic     as QCM+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck++import           Control.Concurrent+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           System.Directory+import           System.IO++prop_toBuilder_String :: String -> Bool+prop_toBuilder_String str = (LT.unpack . LTE.decodeUtf8 . FB.toLazyByteString $ toBuilder str) == str++prop_toBuilder_strict_Text :: ST.Text -> Bool+prop_toBuilder_strict_Text str = (LT.toStrict . LTE.decodeUtf8 . FB.toLazyByteString $ toBuilder str) == str++prop_toBuilder_lazy_Text :: LT.Text -> Bool+prop_toBuilder_lazy_Text str = (LTE.decodeUtf8 . FB.toLazyByteString $ toBuilder str) == str++prop_toBuilder_strict_ByteString :: SBS.ByteString -> Bool+prop_toBuilder_strict_ByteString str = FB.toStrictByteString (toBuilder str) == str++prop_toBuilder_lazy_ByteString :: LBS.ByteString -> Bool+prop_toBuilder_lazy_ByteString str = FB.toLazyByteString (toBuilder str) == str++data TestShow = Foo | Bar | Baz deriving (Show)+instance Arbitrary TestShow where+  arbitrary = elements [Foo, Bar, Baz]++prop_toBuilder_Show :: TestShow -> Bool+prop_toBuilder_Show x = FB.toLazyByteString (toBuilder x) == (LTE.encodeUtf8 . LT.pack $ show x)++prop_concat :: String -> String -> Bool+prop_concat str0 str1 = (LT.unpack . LTE.decodeUtf8 . FB.toLazyByteString $ str0 <:> str1) == str0 <> str1++instance Arbitrary LogLevel where+  arbitrary = elements [LogDebug, LogInfo, LogNotice, LogWarn, LogError, LogCritical, LogAlert, LogEmergency]++prop_broadcastLog :: [(LogLevel, String)] -> Property+prop_broadcastLog msgs = monadicIO $ do+  result <- run $ do+    chan <- newLogChan+    lq <- newLogQueue++    (file0, handle0) <- openTempFile "/tmp" "caster_test_0.log"+    let listener0 = handleListenerFlush defaultFormatter handle0+    thread0 <- forkIO $ relayLog chan LogDebug listener0++    (file1, handle1) <- openTempFile "/tmp" "caster_test_1.log"+    let listener1 = handleListenerFlush defaultFormatter handle1+    thread1 <- forkIO $ relayLog chan LogDebug listener1++    (file2, handle2) <- openTempFile "/tmp" "caster_test_2.log"+    let listener2 = handleListenerFlush defaultFormatter handle2+    thread2 <- forkIO $ relayLog chan LogDebug listener2++    threadb <- forkIO $ broadcastLog lq chan++    mapM_ (uncurry $ logAs lq) msgs++    log0 <- hGetContents handle0+    log1 <- hGetContents handle1+    log2 <- hGetContents handle2++    let !res = log0 == log1 && log1 == log2++    killThread thread0+    killThread thread1+    killThread thread2+    killThread threadb++    removeFile file0+    removeFile file1+    removeFile file2++    pure res++  QCM.assert result
+ test/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}