diff --git a/Control/Logging.hs b/Control/Logging.hs new file mode 100644 --- /dev/null +++ b/Control/Logging.hs @@ -0,0 +1,175 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +module Control.Logging + ( log + , warn + , debug + , errorL + , traceL + , traceShowL + , timedLog + , timedLog' + , timedDebug + , timedDebug' + , withStdoutLogging + , withStderrLogging + , flushLog + , setDebugLevel + , setLogFormat + ) where + +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Trans.Control +import Data.AffineSpace +import Data.IORef +import Data.Monoid +import Data.Text as T +import Data.Thyme +import Debug.Trace +import Prelude hiding (log) +import System.IO.Unsafe +import System.Locale +import System.Log.FastLogger + +logLevel :: IORef LogLevel +{-# NOINLINE logLevel #-} +logLevel = unsafePerformIO $ newIORef LevelDebug + +-- | Set the verbosity level. Messages at our higher than this level are +-- displayed. It defaults to 'LevelDebug'. +setDebugLevel :: LogLevel -> IO () +setDebugLevel = atomicWriteIORef logLevel + +logSet :: IORef LoggerSet +{-# NOINLINE logSet #-} +logSet = unsafePerformIO $ + newIORef (error "Must call withStdoutLogging or withStderrLogging") + +logFormat :: IORef String +{-# NOINLINE logFormat #-} +logFormat = unsafePerformIO $ newIORef "%Y %b-%d %H:%M:%S%Q" + +-- | Set the format used for log timestamps. +setLogFormat :: String -> IO () +setLogFormat = atomicWriteIORef logFormat + +logger :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> IO () +logger _loc !src !lvl str = do + maxLvl <- readIORef logLevel + when (lvl >= maxLvl) $ do + now <- getCurrentTime + fmt <- readIORef logFormat + let stamp = formatTime defaultTimeLocale fmt now + set <- readIORef logSet + pushLogStr set + $ toLogStr (stamp ++ " " ++ renderLevel lvl + ++ " " ++ renderSource src) + <> toLogStr str + <> toLogStr (pack "\n") + where + renderSource :: Text -> String + renderSource txt + | T.null txt = "" + | otherwise = unpack txt ++ ": " + + renderLevel LevelDebug = "[DEBUG]" + renderLevel LevelInfo = "[INFO]" + renderLevel LevelWarn = "[WARN]" + renderLevel LevelError = "[ERROR]" + renderLevel (LevelOther txt) = "[" ++ unpack txt ++ "]" + +-- | This function, or 'withStderrLogging', must be wrapped around whatever +-- region of your application intends to use logging. Typically it would be +-- wrapped around the body of 'main'. +withStdoutLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a +withStdoutLogging f = do + liftIO $ do + set <- newStdoutLoggerSet defaultBufSize + atomicWriteIORef logSet set + f `finally` flushLog + +withStderrLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a +withStderrLogging f = do + liftIO $ do + set <- newStderrLoggerSet defaultBufSize + atomicWriteIORef logSet set + f `finally` flushLog + +flushLog :: MonadIO m => m () +flushLog = liftIO $ do + set <- readIORef logSet + flushLogStr set + +instance MonadLogger IO where + monadLoggerLog = logger + +-- | Synonym for 'Control.Monad.Logger.logInfoN'. This module provides a +-- 'MonadLogger' instance for IO, so this function can be used directly in +-- IO. The only requirement is that you must surround the body of your +-- @main@ function with a call to 'withStdoutLogging' or +-- 'withStderrLogging', to ensure that all logging buffers are properly +-- flushed on exit. +log :: MonadLogger m => Text -> m () +log = logInfoN + +debug :: MonadLogger m => Text -> m () +debug = logDebugN + +warn :: MonadLogger m => Text -> m () +warn = logWarnN + +-- | A logging variant of 'error' which uses 'unsafePerformIO' to output a log +-- message before calling 'error'. +errorL :: Text -> a +errorL str = error (unsafePerformIO (logErrorN str) `seq` unpack str) + +traceL :: Text -> a -> a +traceL str = trace (unsafePerformIO (logDebugN str) `seq` unpack str) + +traceShowL :: Show a => a -> a1 -> a1 +traceShowL x = + let s = show x + in trace (unsafePerformIO (logDebugN (pack s)) `seq` s) + +doTimedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) + => (Text -> m ()) -> Bool -> Text -> m () -> m () +doTimedLog logf wrapped msg f = do + start <- liftIO getCurrentTime + when wrapped $ logf $ msg <> "..." + f `catch` \e -> do + let str = show (e :: SomeException) + wrapup start $ pack $ + if wrapped + then "...FAIL (" ++ str ++ ")" + else " (FAIL: " ++ str ++ ")" + throwIO e + wrapup start $ if wrapped then "...done" else "" + where + wrapup start m = do + end <- liftIO getCurrentTime + logf $ msg <> m <> " [" <> pack (show (end .-. start)) <> "]" + +-- | Output a logging message both before an action begins, and after it ends, +-- reporting the total length of time. If an exception occurred, it is also +-- reported. +timedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) + => Text -> m () -> m () +timedLog = doTimedLog log True + +-- | Like 'timedLog', except that it does only logs when the action has +-- completed or faileda. +timedLog' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) + => Text -> m () -> m () +timedLog' = doTimedLog log False + +-- | A debug variant of 'timedLog'. +timedDebug :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) + => Text -> m () -> m () +timedDebug = doTimedLog debug True + +timedDebug' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) + => Text -> m () -> m () +timedDebug' = doTimedLog debug False diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +opyright (c) 2014 John Wiegley + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/logging.cabal b/logging.cabal new file mode 100644 --- /dev/null +++ b/logging.cabal @@ -0,0 +1,73 @@ +Name: logging +Version: 1.0.0 +Synopsis: Simplified logging in IO for application writers. +License-file: LICENSE +License: MIT +Author: John Wiegley +Maintainer: johnw@newartisans.com +Build-Type: Simple +Cabal-Version: >=1.10 +Category: System +Description: + @logging@ is a wrapper around @monad-logger@ and @fast-logger@ which makes + it easy to log from any 'MonadLogger' environment, or from 'IO'. It + provides the following conveniences on top of those libraries: + . + - A 'MonadLogger' instance for 'IO'. Usually this is bad for libraries, but + can be very convenience for application writers who know they always want + to log from IO to the console. If you need to log to other sources, or to + make logging compile-time optional, use @monad-logger@ directly. + . + - A set of shorter functions to type: 'debug', 'log', 'warn'. + . + - Logging variants of 'error', 'trace' and 'traceShow', called 'errorL', + 'traceL' and 'traceShowL'. These use 'unsafePerformIO' in order to act as + direct replacements, so the usual caveats apply. + . + - A global function, 'setDebugLevel', which uses a global 'IORef' to record + the logging level, saving you from having to carry around the notion of + "verbosity level" in a Reader environment. + . + - A set of "timed" variants, 'timedLog' and 'timedDebug', which report how + long the specified action took to execute in wall-clock time. + +Source-repository head + type: git + location: git://github.com/jwiegley/logging.git + +Library + default-language: Haskell98 + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , binary >= 0.5.1.1 + , bytestring >= 0.9.2.1 + , fast-logger >= 2.1.5 + , old-locale >= 1.0.0.5 + , thyme >= 0.3.1.0 + , monad-control >= 0.3.2.3 + , monad-logger >= 0.3.4.0 + , text >= 0.11.3.1 + , transformers >= 0.3.0.0 + , lifted-base >= 0.2.2.0 + , vector-space >= 0.8.6 + exposed-modules: + Control.Logging + default-extensions: + BangPatterns + FlexibleContexts + OverloadedStrings + +test-suite test + hs-source-dirs: test + default-language: Haskell2010 + main-is: main.hs + type: exitcode-stdio-1.0 + ghc-options: -Wall -threaded + build-depends: + base + , logging + , unix >= 2.5.1.1 + , hspec >= 1.4 + default-extensions: + OverloadedStrings diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,21 @@ +module Main where + +import Control.Exception +import Control.Concurrent +import Control.Logging +import Prelude hiding (log) +import Test.Hspec + +tryAny :: IO a -> IO (Either SomeException a) +tryAny = try + +main :: IO () +main = hspec $ do + describe "simple logging" $ + it "logs output" $ (withStdoutLogging :: IO () -> IO ()) $ do + log "Hello, world!" + timedLog "Did a good thing" $ threadDelay 100000 + _ <- tryAny $ timedLog "Did a bad thing" $ + threadDelay 100000 >> error "foo" + _ <- tryAny $ errorL "Uh oh" + return ()