diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014 Simon Hengel +Copyright (c) 2014-2017 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/logging-facade.cabal b/logging-facade.cabal --- a/logging-facade.cabal +++ b/logging-facade.cabal @@ -1,10 +1,16 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + name: logging-facade -version: 0.1.1 +version: 0.2.0 synopsis: Simple logging abstraction that allows multiple back-ends description: Simple logging abstraction that allows multiple back-ends +homepage: https://github.com/sol/logging-facade#readme +bug-reports: https://github.com/sol/logging-facade/issues license: MIT license-file: LICENSE -copyright: (c) 2014 Simon Hengel +copyright: (c) 2014-2017 Simon Hengel author: Simon Hengel maintainer: Simon Hengel build-type: Simple @@ -17,24 +23,29 @@ library ghc-options: -Wall - hs-source-dirs: src + hs-source-dirs: + src exposed-modules: System.Logging.Facade - System.Logging.Facade.Sink System.Logging.Facade.Class + System.Logging.Facade.Sink System.Logging.Facade.Types + other-modules: + Paths_logging_facade build-depends: base == 4.* , transformers - , template-haskell default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall - hs-source-dirs: test + hs-source-dirs: + test main-is: Spec.hs other-modules: + Helper + System.Logging.Facade.SinkSpec System.Logging.FacadeSpec build-depends: base == 4.* diff --git a/src/System/Logging/Facade/Sink.hs b/src/System/Logging/Facade/Sink.hs --- a/src/System/Logging/Facade/Sink.hs +++ b/src/System/Logging/Facade/Sink.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE CPP #-} module System.Logging.Facade.Sink ( LogSink , defaultLogSink -, setLogSink , getLogSink +, setLogSink +, swapLogSink +, withLogSink ) where +import Control.Concurrent import Data.IORef import System.IO import System.IO.Unsafe (unsafePerformIO) +import Control.Exception import System.Logging.Facade.Types @@ -16,7 +21,7 @@ -- use the unsafePerformIO hack to share one sink across a process logSink :: IORef LogSink -logSink = unsafePerformIO (newIORef defaultLogSink) +logSink = unsafePerformIO (defaultLogSink >>= newIORef) {-# NOINLINE logSink #-} -- | Return the global log sink. @@ -27,9 +32,22 @@ setLogSink :: LogSink -> IO () setLogSink = atomicWriteIORef logSink --- | A log sink that writes log messages to `stderr` -defaultLogSink :: LogSink -defaultLogSink record = hPutStrLn stderr output +-- | Return the global log sink and set it to a new value in one atomic +-- operation. +swapLogSink :: LogSink -> IO LogSink +swapLogSink new = atomicModifyIORef logSink $ \old -> (new, old) + +-- | Set the global log sink to a specified value, run given action, and +-- finally restore the global log sink to its previous value. +withLogSink :: LogSink -> IO () -> IO () +withLogSink sink action = bracket (swapLogSink sink) setLogSink (const action) + +-- | A thread-safe log sink that writes log messages to `stderr` +defaultLogSink :: IO LogSink +defaultLogSink = defaultLogSink_ `fmap` newMVar () + +defaultLogSink_ :: MVar () -> LogSink +defaultLogSink_ mvar record = withMVar mvar (\() -> hPutStrLn stderr output) where level = logRecordLevel record mLocation = logRecordLocation record @@ -40,3 +58,10 @@ formatLocation :: Location -> ShowS formatLocation loc = showString (locationFile loc) . colon . shows (locationLine loc) . colon . shows (locationColumn loc) where colon = showString ":" + +#if !MIN_VERSION_base(4,6,0) +atomicWriteIORef :: IORef a -> a -> IO () +atomicWriteIORef ref a = do + x <- atomicModifyIORef ref (\_ -> (a, ())) + x `seq` return () +#endif diff --git a/src/System/Logging/Facade/Types.hs b/src/System/Logging/Facade/Types.hs --- a/src/System/Logging/Facade/Types.hs +++ b/src/System/Logging/Facade/Types.hs @@ -1,7 +1,7 @@ module System.Logging.Facade.Types where data LogLevel = TRACE | DEBUG | INFO | WARN | ERROR - deriving (Eq, Show, Ord, Bounded, Enum) + deriving (Eq, Show, Read, Ord, Bounded, Enum) data Location = Location { locationPackage :: String diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,17 @@ +module Helper ( + module Test.Hspec +, logSinkSpy +) where + +import Test.Hspec +import Data.IORef + +import System.Logging.Facade.Types +import System.Logging.Facade.Sink + +logSinkSpy :: IO (IO [LogRecord], LogSink) +logSinkSpy = do + ref <- newIORef [] + let spy :: LogSink + spy record = modifyIORef ref (record {logRecordLocation = Nothing} :) + return (readIORef ref, spy) diff --git a/test/System/Logging/Facade/SinkSpec.hs b/test/System/Logging/Facade/SinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Logging/Facade/SinkSpec.hs @@ -0,0 +1,25 @@ +module System.Logging.Facade.SinkSpec (main, spec) where + +import Helper + +import System.Logging.Facade +import System.Logging.Facade.Types +import System.Logging.Facade.Sink + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "withLogSink" $ do + it "sets the global log sink to specified value before running specified action" $ do + (logRecords, spy) <- logSinkSpy + withLogSink spy (info "some log message") + logRecords `shouldReturn` [LogRecord INFO Nothing "some log message"] + + it "restores the original log sink when done" $ do + (logRecords, spy) <- logSinkSpy + setLogSink spy + withLogSink (\_ -> return ()) (return ()) + info "some log message" + logRecords `shouldReturn` [LogRecord INFO Nothing "some log message"] diff --git a/test/System/Logging/FacadeSpec.hs b/test/System/Logging/FacadeSpec.hs --- a/test/System/Logging/FacadeSpec.hs +++ b/test/System/Logging/FacadeSpec.hs @@ -1,7 +1,6 @@ module System.Logging.FacadeSpec (main, spec) where -import Test.Hspec -import Data.IORef +import Helper import System.Logging.Facade.Types import System.Logging.Facade.Sink @@ -14,9 +13,6 @@ spec = do describe "info" $ do it "writes a log message with log level INFO" $ do - ref <- newIORef [] - let captureLogMessage :: LogSink - captureLogMessage record = modifyIORef ref (record {logRecordLocation = Nothing} :) - setLogSink captureLogMessage - info "some log message" - readIORef ref `shouldReturn` [LogRecord INFO Nothing "some log message"] + (logRecords, spy) <- logSinkSpy + withLogSink spy (info "some log message") + logRecords `shouldReturn` [LogRecord INFO Nothing "some log message"]