log-warper 1.8.1 → 1.8.2
raw patch · 23 files changed
+136/−476 lines, 23 filesdep +microlens-mtldep +microlens-platformdep −dlistdep −errorsdep −exceptionsdep ~textdep ~universum
Dependencies added: microlens-mtl, microlens-platform
Dependencies removed: dlist, errors, exceptions, extra, formatting, hashable, lens, network, text-format
Dependency ranges changed: text, universum
Files
- CHANGES.md +14/−1
- examples/Playground.hs +3/−3
- log-warper.cabal +6/−18
- src/System/Wlog.hs +0/−2
- src/System/Wlog/CanLog.hs +1/−4
- src/System/Wlog/Color.hs +8/−10
- src/System/Wlog/Exception.hs +0/−2
- src/System/Wlog/Formatter.hs +3/−5
- src/System/Wlog/HasLoggerName.hs +9/−11
- src/System/Wlog/IOLogger.hs +13/−12
- src/System/Wlog/Launcher.hs +8/−10
- src/System/Wlog/LogHandler.hs +2/−2
- src/System/Wlog/LogHandler/Roller.hs +6/−5
- src/System/Wlog/LogHandler/Simple.hs +7/−9
- src/System/Wlog/LogHandler/Syslog.hs +0/−304
- src/System/Wlog/LoggerConfig.hs +16/−23
- src/System/Wlog/LoggerName.hs +10/−15
- src/System/Wlog/LoggerNameBox.hs +8/−12
- src/System/Wlog/MemoryQueue.hs +11/−13
- src/System/Wlog/PureLogging.hs +6/−8
- src/System/Wlog/Severity.hs +0/−1
- src/System/Wlog/Terminal.hs +0/−2
- test/Test/Wlog/RollingSpec.hs +5/−4
CHANGES.md view
@@ -1,7 +1,20 @@+1.8.2+=====++* Migrate to `universum-1.0.0`.+* [#71](https://github.com/serokell/log-warper/issues/71):+ Use `microlens-platform` instead of `lens`.+ `LoggerMap` is now has field `LoggerName` instead of `Text`.+ `zoomLogger` is now work with `LoggerName` instead of `Text`.+ Remove `LogHandler.Syslog` module and `network` library.+ Remove `extra`, `errors`, `exceptions`, `hashable`, `text-format`, `formatting` dependencies.+ Remove `loggerNameF` function.+ Change `lens` to `microlens-mtl` in tests.+ 1.8.1 ===== -* [#75](https://github.com/serokell/log-warper/issues/55):+* [#75](https://github.com/serokell/log-warper/issues/75): Bump up `universum` lower bound. 1.8.0
examples/Playground.hs view
@@ -34,7 +34,7 @@ showSomeLog :: (CanLog m, MonadIO m) => m () showSomeLog = do- putText "Other log:"+ putTextLn "Other log:" usingLoggerName "naked" $ do logWarning "Some warning" logDebug "Some debug"@@ -45,8 +45,8 @@ let runPlayLog = testLogging >> showSomeLog putStrLn $ encodePretty defConfig $ defaultConfig "example"- putText "Default configurations.."+ putTextLn "Default configurations.." launchSimpleLogging "node" runPlayLog - putText "\nFrom file configurations.."+ putTextLn "\nFrom file configurations.." launchFromFile testLoggerConfigPath "node" runPlayLog
log-warper.cabal view
@@ -1,5 +1,5 @@ name: log-warper-version: 1.8.1+version: 1.8.2 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT@@ -14,7 +14,7 @@ cabal-version: >=1.18 description: This package implements nice and featureful wrapper around hslogger library. tested-with: GHC == 8.0.2- , GHC == 8.2.1+ , GHC == 8.2.2 library exposed-modules: System.Wlog@@ -31,7 +31,6 @@ System.Wlog.LogHandler System.Wlog.LogHandler.Roller System.Wlog.LogHandler.Simple- System.Wlog.LogHandler.Syslog System.Wlog.PureLogging System.Wlog.Severity System.Wlog.Terminal@@ -45,26 +44,18 @@ , containers >= 0.5.7.1 , deepseq >= 1.2.0.0 , directory >= 1.2.6.2- , dlist >= 0.8.0.2- , errors >= 2.1.2- , exceptions >= 0.8.3- , extra >= 1.4.10 , filepath >= 1.4.1 , fmt >= 0.5.0.0- , formatting >= 6.2.2- , hashable >= 1.2.4.0- , lens >= 4.14+ , microlens-platform >= 0.3.9 , monad-control >= 1.0.1.0 , monad-loops >= 0.4.3 , mmorph >= 1.0.9 , mtl >= 2.2.1- , network >= 2.6.3.1 , text >= 1.2.2.0- , text-format >= 0.3.1.1 , time >= 1.6.0.1 , transformers >= 0.5.2 , transformers-base >= 0.4.4- , universum >= 0.9.1+ , universum >= 1.0.0 , unordered-containers >= 0.2.7.1 , vector >= 0.12 , yaml >= 0.8.20@@ -87,10 +78,7 @@ executable play-log main-is: Playground.hs - build-depends: base >= 4.7 && < 5- , exceptions >= 0.8.2.1- , log-warper- , text >= 1.2.2.1+ build-depends: log-warper , universum >= 0.3 , yaml >= 0.8.20 @@ -135,7 +123,7 @@ , filepath , hspec , HUnit- , lens+ , microlens-mtl , log-warper , QuickCheck , universum
src/System/Wlog.hs view
@@ -23,7 +23,6 @@ , module System.Wlog.LoggerNameBox , module System.Wlog.LogHandler.Roller , module System.Wlog.LogHandler.Simple- , module System.Wlog.LogHandler.Syslog , module System.Wlog.PureLogging , module System.Wlog.Severity , module System.Wlog.Terminal@@ -40,7 +39,6 @@ import System.Wlog.LoggerNameBox import System.Wlog.LogHandler.Roller import System.Wlog.LogHandler.Simple-import System.Wlog.LogHandler.Syslog import System.Wlog.PureLogging import System.Wlog.Severity import System.Wlog.Terminal
src/System/Wlog/CanLog.hs view
@@ -26,9 +26,6 @@ import Universum -import Control.Monad.Except (ExceptT)-import Control.Monad.Trans (MonadTrans (lift))- import System.Wlog.HasLoggerName (HasLoggerName (..)) import System.Wlog.IOLogger (logM) import System.Wlog.LoggerName (LoggerName (..))@@ -151,4 +148,4 @@ liftLogIO :: WithLoggerIO m => (IO a -> IO b) -> LoggerNameBox IO a -> m b liftLogIO ioFunc action = do logName <- askLoggerName- liftIO $ ioFunc $ usingLoggerName logName $ action+ liftIO $ ioFunc $ usingLoggerName logName action
src/System/Wlog/Color.hs view
@@ -14,16 +14,14 @@ , colorizerBuilder ) where -import qualified Data.Text as T-import Data.Text.Lazy.Builder as B-import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow),- ColorIntensity (Vivid),- ConsoleLayer (Foreground),- SGR (Reset, SetColor), setSGRCode)-import Universum+import Universum -import System.Wlog.Severity (Severity (..))+import Data.Text.Lazy.Builder as B+import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow), ColorIntensity (Vivid),+ ConsoleLayer (Foreground), SGR (Reset, SetColor), setSGRCode) +import System.Wlog.Severity (Severity (..))+ -- | Defines pre- and post-printed characters for printing colorized text. table :: Severity -> (String, String) table severity = case severity of@@ -39,8 +37,8 @@ -- | Colorizes "Text". colorizer :: Severity -> Text -> Text colorizer pr s =- let (before, after) = table pr in T.pack before <> s <> T.pack after+ let (before, after) = table pr in toText before <> s <> toText after colorizerBuilder :: Severity -> Builder -> Builder colorizerBuilder pr s =- let (before, after) = table pr in B.fromText (T.pack before) <> s <> B.fromText (T.pack after)+ let (before, after) = table pr in B.fromText (toText before) <> s <> B.fromText (toText after)
src/System/Wlog/Exception.hs view
@@ -11,8 +11,6 @@ import Universum -import Control.Exception.Base (Exception)- import System.Wlog.CanLog (WithLogger, WithLoggerIO, logError) -- | Logs exception's description with ''System.Wlog.Severity.Error' 'System.Wlog.Severity.Severity'
src/System/Wlog/Formatter.hs view
@@ -30,7 +30,6 @@ import Universum import Control.Concurrent (myThreadId)-import Data.Monoid (mconcat) import Data.Text.Lazy.Builder as B import Data.Time (formatTime, getCurrentTime, getZonedTime) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, picosecondsToDiffTime)@@ -151,8 +150,7 @@ -- -- * @$utcTime@ - The current time in UTC Time simpleLogFormatter :: Text -> LogFormatter a-simpleLogFormatter format h logRecord loggername =- tfLogFormatter "%F %X %Z" format h logRecord loggername+simpleLogFormatter = tfLogFormatter "%F %X %Z" ---------------------------------------------------------------------------- -- Log-warper functionality@@ -181,7 +179,7 @@ multiplier = 10 ^ m picoseconds = diffTimeToPicoseconds utctDayTime roundedPicoseconds = (picoseconds `div` multiplier) * multiplier- pure $ UTCTime { utctDayTime = picosecondsToDiffTime roundedPicoseconds, .. }+ pure UTCTime { utctDayTime = picosecondsToDiffTime roundedPicoseconds, .. } stdoutFormatter :: (UTCTime -> Text) -> Bool -> Bool -> LogFormatter a stdoutFormatter timeF isShowTime isShowTid handle record message = do@@ -209,7 +207,7 @@ = simpleLogFormatter format handle record where- format = mconcat $!+ format = mconcat [ colorizer priority $ "[$loggername:$prio" <> tidShower <> "] " , timeShower , "$msg"
src/System/Wlog/HasLoggerName.hs view
@@ -13,19 +13,17 @@ , withSublogger ) where -import Universum+import Universum -import Control.Monad.Except (ExceptT (..))-import Control.Monad.Morph (MFunctor (..))-import qualified Control.Monad.RWS as RWSLazy-import qualified Control.Monad.RWS.Strict as RWSStrict-import qualified Control.Monad.State as StateLazy (StateT)-import Control.Monad.State.Strict (StateT)-import Control.Monad.Trans (MonadTrans, lift)-import Control.Monad.Trans.Cont (ContT, mapContT)-import Control.Monad.Writer (WriterT (..))+import Control.Monad.Morph (MFunctor (..))+import Control.Monad.Trans.Cont (ContT, mapContT)+import Control.Monad.Writer (WriterT (..)) -import System.Wlog.LoggerName (LoggerName)+import System.Wlog.LoggerName (LoggerName)++import qualified Control.Monad.RWS as RWSLazy+import qualified Control.Monad.RWS.Strict as RWSStrict+import qualified Control.Monad.State as StateLazy (StateT) -- | This type class exists to remove boilerplate logging -- by adding the logger's name to the context in each module.
src/System/Wlog/IOLogger.hs view
@@ -53,8 +53,8 @@ import Universum import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar)-import Control.Lens (makeLenses) import Data.Maybe (fromJust)+import Lens.Micro.Platform (makeLenses) import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO) @@ -110,12 +110,12 @@ logInternalState :: MVar LogInternalState -- note: only kick up tree if handled locally logInternalState = unsafePerformIO $ do- let liTree = M.singleton rootLoggerName $+ let liTree = M.singleton rootLoggerName Logger { _lLevel = Just warningPlus , _lName = "" , _lHandlers = []} liPrefix = Nothing- newMVar $ LogInternalState {..}+ newMVar LogInternalState {..} {- | Given a name, return all components of it, starting from the root. Example return value:@@ -125,7 +125,7 @@ -} componentsOfName :: LoggerName -> [LoggerName] componentsOfName (LoggerName name) =- rootLoggerName : (LoggerName <$> (joinComp (T.splitOn "." name) ""))+ rootLoggerName : (LoggerName <$> joinComp (T.splitOn "." name) "") where joinComp [] _ = [] joinComp (x:xs) "" = x : joinComp xs x@@ -170,13 +170,14 @@ return (LogInternalState newlt liPrefix, result) where createLoggers :: [LoggerName] -> LogTree -> LogTree- createLoggers [] lt = lt -- No names to add; return tree unmodified- createLoggers (x:xs) lt = -- Add logger to tree- createLoggers xs $- if M.member x lt- then lt- else M.insert x (defaultLogger & lName .~ x) lt+ createLoggers xs lt = foldl' addLoggerToTree lt xs -- Add logger to tree + addLoggerToTree :: LogTree -> LoggerName -> LogTree+ addLoggerToTree lt x =+ if M.member x lt+ then lt+ else M.insert x (defaultLogger & lName .~ x) lt+ defaultLogger :: Logger defaultLogger = Logger Nothing [] (error "log-warper has some strange code") -- ???!??! @@ -204,7 +205,7 @@ getLoggerSeverities :: MonadIO m => LoggerName -> m Severities getLoggerSeverities name = do pl <- parentLoggers name- case catMaybes . map (view lLevel) $ (l : pl) of+ case mapMaybe (view lLevel) (l : pl) of [] -> pure debugPlus (x:_) -> pure x @@ -296,7 +297,7 @@ removeAllHandlers :: MonadIO m => m () removeAllHandlers = liftIO $ modifyMVar_ logInternalState $ \LogInternalState{..} -> do- let allHandlers = M.foldr (\l r -> concat [r, view lHandlers l]) [] liTree+ let allHandlers = M.foldr (\l r -> r ++ view lHandlers l) [] liTree mapM_ (\(HandlerT h) -> close h) allHandlers let newTree = map (lHandlers .~ []) liTree return $ LogInternalState newTree liPrefix
src/System/Wlog/Launcher.hs view
@@ -37,11 +37,10 @@ import Universum -import Control.Error.Util ((?:)) import Control.Exception (throwIO)-import Control.Lens (zoom, (.=), (?=)) import Data.Time (UTCTime) import Data.Yaml (decodeFileEither)+import Lens.Micro.Platform (zoom, (.=), (?=)) import System.Directory (createDirectoryIfMissing) import System.FilePath ((</>)) @@ -51,7 +50,7 @@ import System.Wlog.LoggerConfig (HandlerWrap (..), LoggerConfig (..), LoggerTree (..), fromScratch, lcConsoleAction, lcShowTime, lcTree, ltSeverity, productionB, zoomLogger)-import System.Wlog.LoggerName (LoggerName (..))+import System.Wlog.LoggerName (LoggerName) import System.Wlog.LoggerNameBox (LoggerNameBox, usingLoggerName) import System.Wlog.LogHandler (LogHandler (setFormatter)) import System.Wlog.LogHandler.Roller (rotationFileHandler)@@ -82,7 +81,7 @@ liftIO $ setPrefix _lcLogsDirectory processLoggers mempty _lcTree where- handlerPrefix = _lcLogsDirectory ?: "."+ handlerPrefix = fromMaybe "." _lcLogsDirectory logMapper = appEndo _lcMapper timeF = fromMaybe centiUtcTimeF mTimeFunction isShowTime = getAny _lcShowTime@@ -98,10 +97,10 @@ processLoggers parent LoggerTree{..} = do -- This prevents logger output to appear in terminal unless (parent == mempty && isNothing consoleAction) $- setSeveritiesMaybe parent (_ltSeverity)+ setSeveritiesMaybe parent _ltSeverity forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do- let fileSeverities = (_ltSeverity) ?: debugPlus+ let fileSeverities = fromMaybe debugPlus _ltSeverity let handlerPath = handlerPrefix </> _hwFilePath case handlerFabric of HandlerFabric fabric -> do@@ -112,9 +111,8 @@ thisLoggerHandler <- fmt <$> handlerCreator updateGlobalLogger parent $ addHandler thisLoggerHandler - for_ (HM.toList _ltSubloggers) $ \(name, loggerConfig) -> do- let thisLoggerName = LoggerName name- let thisLogger = parent <> logMapper thisLoggerName+ for_ (HM.toList _ltSubloggers) $ \(loggerName, loggerConfig) -> do+ let thisLogger = parent <> logMapper loggerName processLoggers thisLogger loggerConfig -- | Parses logger config from given file path.@@ -187,7 +185,7 @@ lcConsoleAction .= Last (Just defaultHandleAction) zoom lcTree $ do ltSeverity ?= warningPlus- zoomLogger (getLoggerName loggerName) $ do+ zoomLogger loggerName $ ltSeverity ?= debugPlus {- | Set ups the logging with 'defaultConfig' and runs the action with the given 'LoggerName'.
src/System/Wlog/LogHandler.hs view
@@ -42,9 +42,9 @@ -- given by the most recent call to 'setLevel'. logHandlerMessage :: (MonadIO m, LogHandler a) => a -> LogRecord -> LoggerName -> m () logHandlerMessage h lr@(LR pri _) logname =- when (pri `Set.member` (getLevel h)) $ do+ when (pri `Set.member` getLevel h) $ do let lName = getLoggerName logname- formattedMsg <- liftIO $ (getFormatter h) h lr lName+ formattedMsg <- liftIO $ getFormatter h h lr lName emit h formattedMsg lName -- | Tag identifying handlers.
src/System/Wlog/LogHandler/Roller.hs view
@@ -11,12 +11,13 @@ import Control.Concurrent (modifyMVar, modifyMVar_, withMVar) import Data.Text.Lazy.Builder as B-import Formatting (sformat, shown, (%))+import Fmt ((+||), (||+)) import System.Directory (removeFile, renameFile) import System.FilePath ((<.>)) import System.IO (Handle, IOMode (ReadWriteMode), SeekMode (AbsoluteSeek, SeekFromEnd), hClose, hFileSize, hFlush, hSeek)+ import System.Wlog.FileUtils (whenExist) import System.Wlog.Formatter (LogFormatter, nullFormatter) import System.Wlog.LoggerConfig (RotationParameters (..), isValidRotation)@@ -49,7 +50,7 @@ emit rh bldr _ = liftIO $ rhWriteAction rh (error "Handler is used internally") (toText . B.toLazyText $ bldr) close RollerHandler{..} = liftIO $ withMVar rhFileHandle rhCloseAction -data InvalidRotation = InvalidRotation !Text+newtype InvalidRotation = InvalidRotation Text deriving (Show, Eq) instance Exception InvalidRotation@@ -58,7 +59,7 @@ logIndex handlerPath i = handlerPath <.> show i rollerReadback :: MonadIO m => RollerHandler -> Int -> m [Text]-rollerReadback RollerHandler{..} logsNum = liftIO $ do+rollerReadback RollerHandler{..} logsNum = liftIO $ modifyMVar rhFileHandle $ \h -> do hFlush h hSeek h AbsoluteSeek 0@@ -90,7 +91,7 @@ for_ [lastIndex - 1,lastIndex - 2 .. 0] $ \i -> do let oldLogFile = logIndex handlerPath i let newLogFile = logIndex handlerPath (i + 1)- whenExist oldLogFile $ (`renameFile` newLogFile)+ whenExist oldLogFile (`renameFile` newLogFile) let zeroIndex = logIndex handlerPath 0 renameFile handlerPath zeroIndex let lastLogFile = logIndex handlerPath lastIndex@@ -108,7 +109,7 @@ -> m RollerHandler rotationFileHandler rp@RotationParameters{..} _ _ | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $- sformat ("Rotation parameters must be positive: "%shown) rp+ "Rotation parameters must be positive: "+||rp||+"" rotationFileHandler rp@RotationParameters{..} handlerPath rhSeverities = liftIO $ do GenericHandler{..} <- fileHandler handlerPath rhSeverities rhFileHandle <- newMVar privData
src/System/Wlog/LogHandler/Simple.hs view
@@ -27,7 +27,6 @@ import Universum import Control.Concurrent (modifyMVar_, withMVar)-import Control.Exception (SomeException) import Data.Text.Lazy.Builder as B import Data.Typeable (Typeable) import System.Directory (createDirectoryIfMissing)@@ -36,8 +35,7 @@ import System.Wlog.Formatter (LogFormatter, nullFormatter) import System.Wlog.LogHandler (LogHandler (..), LogHandlerTag (..))-import System.Wlog.MemoryQueue (MemoryQueue)-import System.Wlog.MemoryQueue as MQ+import System.Wlog.MemoryQueue (MemoryQueue, newMemoryQueue, pushFront, queueToList) import System.Wlog.Severity (Severities) import qualified Data.Text.IO as TIO@@ -56,12 +54,12 @@ instance Typeable a => LogHandler (GenericHandler a) where getTag = ghTag setLevel sh s = sh {severities = s}- getLevel sh = severities sh+ getLevel = severities setFormatter sh f = sh{formatter = f}- getFormatter sh = formatter sh- readBack sh i = liftIO $ withMVar (readBackBuffer sh) $ \mq' -> pure $! take i . MQ.toList $ mq'- emit sh bldr _ = liftIO $ (writeFunc sh) (privData sh) (toText . B.toLazyText $ bldr)- close sh = liftIO $ (closeFunc sh) (privData sh)+ getFormatter = formatter+ readBack sh i = liftIO $ withMVar (readBackBuffer sh) $ \mq' -> pure $! take i . queueToList $ mq'+ emit sh bldr _ = liftIO $ writeFunc sh (privData sh) (toText . B.toLazyText $ bldr)+ close sh = liftIO $ closeFunc sh (privData sh) -- | Default action which just prints to handle using given message. defaultHandleAction :: Handle -> Text -> IO ()@@ -83,7 +81,7 @@ , MVar (MemoryQueue Text) ) createWriteFuncWrapper action lock = do- memoryQueue <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB+ memoryQueue <- newMVar $ newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB let customWriteFunc :: Handle -> Text -> IO () customWriteFunc hdl msg = withMVar lock $ const $ do
− src/System/Wlog/LogHandler/Syslog.hs
@@ -1,304 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}--{- |- Module : System.Log.LogHandler.Syslog- Copyright : Copyright (C) 2004-2011 John Goerzen- License : BSD3-- Maintainer : John Goerzen <jgoerzen@complete.org>- Stability : provisional- Portability: portable--Syslog handler for the Haskell Logging Framework--Written by John Goerzen, jgoerzen\@complete.org--This module implements an interface to the Syslog service commonly-found in Unix\/Linux systems. This interface is primarily of interest to-developers of servers, as Syslog does not typically display messages in-an interactive fashion.--This module is written in pure Haskell and is capable of logging to a local-or remote machine using the Syslog protocol.--You can create a new Syslog 'LogHandler' by calling 'openlog'.--More information on the Haskell Logging Framework can be found at-"System.Log.Logger". This module can also be used outside-of the rest of that framework for those interested in that.--}--module System.Wlog.LogHandler.Syslog- ( SyslogHandler -- No constructors.- -- * Handler Initialization- , openlog- -- * Advanced handler initialization-#ifndef mingw32_HOST_OS- , openlog_local-#endif- , openlog_remote- , openlog_generic- -- * Data Types- , Facility(..)- , Option(..)- ) where--import Universum hiding (Option, identity)--import Control.Monad (void, when)-import Data.Bits (shiftL, (.|.))-import Data.Text.Lazy.Builder as B-import Network.BSD (getHostByName, hostAddresses)-import Network.Socket (Family (..), HostName, PortNumber, SockAddr (..), Socket,- SocketType (Datagram, Stream), connect, socket)-#ifndef mingw32_HOST_OS-import System.Posix.Process (getProcessID)-#endif-import System.IO ()--import System.Wlog.Formatter (LogFormatter, varFormatter)-import System.Wlog.LogHandler (LogHandler (..), LogHandlerTag (HandlerOther))-import System.Wlog.Severity (Severities, Severity (..))---import qualified Control.Exception as E-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy.IO as TIO-import qualified Network.Socket as S-import qualified Network.Socket.ByteString as NBS--code_of_sev :: Severities -> Int-code_of_sev sevs =- case fromMaybe Debug (fst <$> Set.minView sevs) of- Error -> 3- Warning -> 4- Notice -> 5- Info -> 6- Debug -> 7--{- | Facilities are used by the system to determine where messages-are sent. -}--data Facility- = KERN -- ^ Kernel messages; you should likely never use this in your programs- | USER -- ^ General userland messages. Use this if nothing else is appropriate- | MAIL -- ^ E-Mail system- | DAEMON -- ^ Daemon (server process) messages- | AUTH -- ^ Authentication or security messages- | SYSLOG -- ^ Internal syslog messages; you should likely never use this in your programs- | LPR -- ^ Printer messages- | NEWS -- ^ Usenet news- | UUCP -- ^ UUCP messages- | CRON -- ^ Cron messages- | AUTHPRIV -- ^ Private authentication messages- | FTP -- ^ FTP messages- | LOCAL0 -- ^ LOCAL0 through LOCAL7 are reserved for you to customize as you wish- | LOCAL1- | LOCAL2- | LOCAL3- | LOCAL4- | LOCAL5- | LOCAL6- | LOCAL7- deriving (Eq, Show, Read)--code_of_fac :: Facility -> Int-code_of_fac f = case f of- KERN -> 0- USER -> 1- MAIL -> 2- DAEMON -> 3- AUTH -> 4- SYSLOG -> 5- LPR -> 6- NEWS -> 7- UUCP -> 8- CRON -> 9- AUTHPRIV -> 10- FTP -> 11- LOCAL0 -> 16- LOCAL1 -> 17- LOCAL2 -> 18- LOCAL3 -> 19- LOCAL4 -> 20- LOCAL5 -> 21- LOCAL6 -> 22- LOCAL7 -> 23--makeCode :: Facility -> Set Severity -> Int-makeCode fac sevs =- let faccode = code_of_fac fac- pricode = code_of_sev sevs- in (faccode `shiftL` 3) .|. pricode---- | Options for 'openlog'.-data Option- = PID -- ^ Automatically log process ID (PID) with each message- | PERROR -- ^ Send a copy of each message to stderr- deriving (Eq, Show, Read)--data SyslogHandler = SyslogHandler- { options :: [Option]- , facility :: Facility- , identity :: String- , logsocket :: Socket- , address :: SockAddr- , sock_type :: SocketType- , severities :: Set Severity- , formatter :: LogFormatter SyslogHandler- }--{- | Initialize the Syslog system using the local system's default interface,-\/dev\/log. Will return a new 'System.Log.Handler.LogHandler'.--On Windows, instead of using \/dev\/log, this will attempt to send-UDP messages to something listening on the syslog port (514) on localhost.--Use 'openlog_remote' if you need more control.--}--openlog :: String -- ^ The name of this program -- will be- -- prepended to every log message- -> [Option] -- ^ A list of 'Option's. The list [] is- -- perfectly valid. ['PID'] is probably- -- most common here.- -> Facility -- ^ The 'Facility' value to pass to the- -- syslog system for every message logged- -> Severities -- ^ Messages logged below this priority- -- will be ignored. To include every- -- message, set this to 'DEBUG'.- -> IO SyslogHandler -- ^ Returns the new handler-#ifdef mingw32_HOST_OS-openlog = openlog_remote AF_INET "localhost" 514-#elif darwin_HOST_OS-openlog = openlog_local "/var/run/syslog"-#else-openlog = openlog_local "/dev/log"-#endif--{- | Initialize the Syslog system using an arbitrary Unix socket (FIFO).--Not supported under Windows.--}--#ifndef mingw32_HOST_OS-openlog_local :: String -- ^ Path to FIFO- -> String -- ^ Program name- -> [Option] -- ^ 'Option's- -> Facility -- ^ Facility value- -> Severities -- ^ Severities- -> IO SyslogHandler-openlog_local fifopath ident options fac sevs =- do (s, t) <- do -- "/dev/log" is usually Datagram,- -- but most of syslog loggers allow it to be- -- of Stream type. glibc's" openlog()"- -- does roughly the similar thing:- -- http://www.gnu.org/software/libc/manual/html_node/openlog.html-- s <- socket AF_UNIX Stream 0- tryStream s `E.catch` (onIOException (fallbackToDgram s))- openlog_generic s (SockAddrUnix fifopath) t ident options fac sevs-- where onIOException :: IO a -> E.IOException -> IO a- onIOException a _ = a-- tryStream :: Socket -> IO (Socket, SocketType)- tryStream s =- do connect s (SockAddrUnix fifopath)- return (s, Stream)-- fallbackToDgram :: Socket -> IO (Socket, SocketType)- fallbackToDgram s =- do S.close s -- close Stream variant- d <- socket AF_UNIX Datagram 0- return (d, Datagram)-#endif--{- | Log to a remote server via UDP. -}-openlog_remote- :: Family -- ^ Usually AF_INET or AF_INET6; see Network.Socket- -> HostName -- ^ Remote hostname. Some use @localhost@- -> PortNumber -- ^ 514 is the default for syslog- -> String -- ^ Program name- -> [Option] -- ^ 'Option's- -> Facility -- ^ Facility value- -> Severities -- ^ Severity limit- -> IO SyslogHandler-openlog_remote fam hostname port ident options fac sevs =- do- he <- getHostByName hostname- s <- socket fam Datagram 0- let addr = SockAddrInet port (fromMaybe (error "head in openlog_remote") $- head (hostAddresses he))- openlog_generic s addr Datagram ident options fac sevs--{- | The most powerful initialization mechanism. Takes an open datagram-socket. -}-openlog_generic :: Socket -- ^ A datagram socket- -> SockAddr -- ^ Address for transmissions- -> SocketType -- ^ socket connection mode (stream / datagram)- -> String -- ^ Program name- -> [Option] -- ^ 'Option's- -> Facility -- ^ Facility value- -> Severities -- ^ Severity limit- -> IO SyslogHandler-openlog_generic sock addr sock_t ident opt fac sevs =- return (SyslogHandler { options = opt,- facility = fac,- identity = ident,- logsocket = sock,- address = addr,- sock_type = sock_t,- severities = sevs,- formatter = syslogFormatter- })--syslogFormatter :: LogFormatter SyslogHandler-syslogFormatter sh lr logname =- let format = "[$loggername/$prio] $msg"- in varFormatter [] format sh lr logname---instance LogHandler SyslogHandler where- getTag = const $ HandlerOther "SyslogHandlerTag"- setLevel sh s = sh{severities = s}- getLevel sh = severities sh- setFormatter sh f = sh{formatter = f}- getFormatter sh = formatter sh- readBack _ _ = pure []- emit sh bldr _ = liftIO $ do- when (elem PERROR (options sh)) (TIO.hPutStrLn stderr (B.toLazyText bldr))- pidPart <- getPidPart- void $ sendstr (toSyslogFormat (toText $ B.toLazyText bldr) pidPart)- where- prio = getLevel sh- sendstr :: Text -> IO ()- sendstr t | T.null t = pass- sendstr omsg = do- let omsg' = TE.encodeUtf8 omsg- sent <- case sock_type sh of- Datagram -> NBS.sendTo (logsocket sh) omsg' (address sh)- Stream -> NBS.send (logsocket sh) omsg'- sck ->- error $ "sysloghandler: unsupported socket type " <> show sck <>- " only datagram/stream sockets are supported"- sendstr $ T.drop (fromIntegral sent) omsg- toSyslogFormat m pidPart =- "<" <> code <> ">" <> T.pack identity' <> T.pack pidPart <> ": " <> m <> "\0"- code = show $ makeCode (facility sh) prio- identity' = identity sh- getPidPart = if elem PID (options sh)- then getPid >>= \pid -> return ("[" ++ pid ++ "]")- else return ""- getPid :: IO String- getPid =-#ifndef mingw32_HOST_OS- getProcessID >>= return . show-#else- return "windows"-#endif-- close = liftIO . S.close . logsocket
src/System/Wlog/LoggerConfig.hs view
@@ -58,39 +58,32 @@ import Universum -import Control.Lens (at, makeLenses, zoom, _Just)-import Control.Monad.State (put) import Data.Aeson (withObject)-import Data.Monoid (Any (..))-import Data.Text (Text) import Data.Traversable (for)-import Data.Word (Word64) import Data.Yaml (FromJSON (..), Object, Parser, ToJSON (..), Value (..), object, (.!=), (.:), (.:?), (.=))-import Formatting (bprint, shown)-import GHC.Generics (Generic)+import Fmt (build, (||+))+import Lens.Micro.Platform (at, makeLenses, zoom, _Just) import System.FilePath (normalise) -import System.Wlog.LoggerName (LoggerName)+import System.Wlog.LoggerName (LoggerName (..)) import System.Wlog.LogHandler.Simple (defaultHandleAction) import System.Wlog.Severity (Severities, allSeverities, debugPlus, errorPlus, infoPlus, noticePlus, warningPlus) import qualified Data.HashMap.Strict as HM hiding (HashMap) import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Buildable as Buildable import qualified Data.Vector as Vector ---------------------------------------------------------------------------- -- Utilites & helpers ---------------------------------------------------------------------------- -filterObject :: [Text] -> HashMap Text a -> HashMap Text a-filterObject excluded = HM.filterWithKey $ \k _ -> k `notElem` excluded+filterObject :: [Text] -> HashMap Text a -> HashMap LoggerName a+filterObject excluded = HM.fromList . map (first LoggerName) . HM.toList . HM.filterWithKey (\k _ -> k `notElem` excluded) parseSeverities :: Object -> Text -> Parser (Maybe Severities)-parseSeverities o term = do+parseSeverities o term = case HM.lookup term o of Just value -> case value of String word -> case word of@@ -100,10 +93,10 @@ "Notice+" -> pure $ Just noticePlus "Warning+" -> pure $ Just warningPlus "Error+" -> pure $ Just errorPlus- _ -> fail $ T.unpack $ "Unknown severity: " <> word+ _ -> fail $ toString $ "Unknown severity: " <> word Array sevs -> Just . Set.fromList . Vector.toList <$> Vector.mapM parseJSON sevs _ -> fail "Incorrect severities format"- Nothing -> pure $ Nothing+ Nothing -> pure Nothing ---------------------------------------------------------------------------- -- LoggerTree@@ -121,7 +114,7 @@ makeLenses ''HandlerWrap -type LoggerMap = HashMap Text LoggerTree+type LoggerMap = HashMap LoggerName LoggerTree -- | Stores configuration for hierarchical loggers. data LoggerTree = LoggerTree@@ -170,8 +163,8 @@ (manyFiles :: [FilePath]) <- map normalise <$> (o .:? "files" .!= []) handlers <- o .:? "handlers" .!= [] let fileHandlers =- map (\fp -> HandlerWrap fp Nothing) $- maybe [] (:[]) singleFile ++ manyFiles+ map (`HandlerWrap` Nothing) $+ maybeToList singleFile ++ manyFiles let _ltFiles = fileHandlers <> handlers _ltSeverity <- parseSeverities o "severity" _ltSubloggers <- for (filterObject nonLoggers o) parseJSON@@ -183,13 +176,13 @@ fromScratch = executingState mempty -- | Zooming into logger name with putting specific key.-zoomLogger :: Text -> State LoggerTree () -> State LoggerTree ()+zoomLogger :: LoggerName -> State LoggerTree () -> State LoggerTree () zoomLogger loggerName initializer = zoom (ltSubloggers.at loggerName) $ do put $ Just mempty zoom _Just initializer ------------------------------------------------------------------------------- Logger rotattion+-- Logger rotation ---------------------------------------------------------------------------- -- | Parameters for logging rotation.@@ -198,8 +191,8 @@ , rpKeepFiles :: !Word -- ^ number of files to keep } deriving (Generic, Show) -instance Buildable.Buildable RotationParameters where- build = bprint shown+instance Buildable RotationParameters where+ build x = x||+"" instance ToJSON RotationParameters @@ -312,7 +305,7 @@ , "termSeveritiesErr" .= _lcTermSeverityErr , "showTime" .= getAny _lcShowTime , "showTid" .= getAny _lcShowTid- , "printOutput" .= maybe False (const True) (getLast _lcConsoleAction)+ , "printOutput" .= isJust (getLast _lcConsoleAction) , "filePrefix" .= _lcLogsDirectory , ("logTree", toJSON _lcTree) ]
src/System/Wlog/LoggerName.hs view
@@ -2,23 +2,17 @@ module System.Wlog.LoggerName ( LoggerName (..)- , loggerNameF ) where -import Universum+import Universum -import Data.Hashable (Hashable)-import Data.Semigroup (Semigroup)-import qualified Data.Semigroup as Semigroup-import Data.String (IsString)-import Data.Text.Buildable (Buildable)-import qualified Data.Text.Buildable as Buildable-import Formatting (Format, bprint, build, stext)+import Data.Aeson.Types (ToJSON, ToJSONKey (..), toJSONKeyText)+import Fmt (build) -- | Logger name to keep in context. newtype LoggerName = LoggerName { getLoggerName :: Text- } deriving (Show, IsString, Eq, Ord, Hashable)+ } deriving (Show, IsString, Eq, Ord, Hashable, Generic) -- | Defined such that @n1@ is parent for @(n1 <> n2)@ -- (see <http://hackage.haskell.org/package/hslogger-1.2.10/docs/System-Log-Logger.html hslogger description>).@@ -30,11 +24,12 @@ instance Monoid LoggerName where mempty = ""- mappend = (Semigroup.<>)+ mappend = (<>) instance Buildable LoggerName where- build = bprint stext . getLoggerName+ build = build . getLoggerName --- | 'LoggerName' formatter which restricts type.-loggerNameF :: Format r (LoggerName -> r)-loggerNameF = build+instance ToJSON LoggerName++instance ToJSONKey LoggerName where+ toJSONKey = toJSONKeyText getLoggerName
src/System/Wlog/LoggerNameBox.hs view
@@ -11,20 +11,16 @@ , usingLoggerName ) where -import Universum+import Universum -import Control.Monad.Base (MonadBase)-import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)-import Control.Monad.Except (MonadError)-import Control.Monad.Fix (MonadFix)-import Control.Monad.Morph (MFunctor (..))-import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT)-import Control.Monad.State.Strict (MonadState)-import Control.Monad.Trans (MonadIO, MonadTrans, lift)-import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Base (MonadBase)+import Control.Monad.Except (MonadError)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Morph (MFunctor (..))+import Control.Monad.Trans.Control (MonadBaseControl (..)) -import System.Wlog.HasLoggerName (HasLoggerName (..))-import System.Wlog.LoggerName (LoggerName)+import System.Wlog.HasLoggerName (HasLoggerName (..))+import System.Wlog.LoggerName (LoggerName) -- | Default implementation of `WithNamedLogger`. newtype LoggerNameBox m a = LoggerNameBox
src/System/Wlog/MemoryQueue.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE BangPatterns #-} -- | Queue for in-memory logs. Rolls out old logging if size of queue -- is bigger than predefined limit.@@ -10,20 +9,19 @@ , newMemoryQueue , popLast , pushFront- , toList+ , queueToList -- * Useful lenses , mqMemSize , mqLimit ) where -import Control.Lens (to)-import Data.Sequence (Seq, ViewR (..), viewr, (<|))-import Universum hiding (toList)-import qualified Universum as U-import qualified Data.Text as T+import Universum -import Control.Lens (makeLenses)+import Data.Sequence (ViewR (..), viewr, (<|))+import Lens.Micro.Platform (makeLenses) +import qualified Data.Text as T+ -- | Class for objects that have size. Implementations can take size -- as amount of memory items take, as amount of items in container, -- etc.@@ -72,10 +70,10 @@ -- Resize the queue so that the inner @Seq@ won't contain more than mqLimit -- elements. resize :: Sized a => MemoryQueue a -> MemoryQueue a- resize theQueue = case _mqMemSize theQueue > _mqLimit theQueue of- False -> theQueue- True -> let (_, q') = popLast theQueue in resize $! q'+ resize theQueue = if _mqMemSize theQueue > _mqLimit theQueue+ then (let (_, q') = popLast theQueue in resize $! q')+ else theQueue -- | Converts queue to list of messages.-toList :: (Sized a) => MemoryQueue a -> [a]-toList = view $ mqQueue . to U.toList+queueToList :: (Sized a) => MemoryQueue a -> [a]+queueToList = toList . view mqQueue
src/System/Wlog/PureLogging.hs view
@@ -28,7 +28,7 @@ import Control.Monad.Morph (MFunctor (..)) import Control.Monad.State.Strict (modify')-import Control.Monad.Trans (MonadTrans (lift))+import Data.Sequence ((|>)) import System.Wlog.CanLog (CanLog (..), WithLogger) import System.Wlog.HasLoggerName (HasLoggerName (..))@@ -36,8 +36,6 @@ import System.Wlog.LoggerNameBox (LoggerNameBox (..), usingLoggerName) import System.Wlog.Severity (Severity (..)) -import qualified Data.DList as DL (DList, snoc)- -- | Holds all required information for 'dispatchLoggerName' function. data LogEvent = LogEvent { leLoggerName :: !LoggerName@@ -53,19 +51,19 @@ -- TODO: Should we use some @Data.Tree@-like structure to observe message only -- by chosen logger names? newtype PureLogger m a = PureLogger- { runPureLogger :: StateT (DL.DList LogEvent) m a- } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (DL.DList LogEvent),+ { runPureLogger :: StateT (Seq LogEvent) m a+ } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (Seq LogEvent), MonadThrow, HasLoggerName) instance Monad m => CanLog (PureLogger m) where- dispatchMessage leLoggerName leSeverity leMessage = modify' (flip DL.snoc LogEvent{..})+ dispatchMessage leLoggerName leSeverity leMessage = modify' (|> LogEvent{..}) instance MFunctor PureLogger where hoist f = PureLogger . hoist f . runPureLogger -- | Return log of pure logging action as list of 'LogEvent'. runPureLog :: Functor m => PureLogger m a -> m (a, [LogEvent])-runPureLog = fmap (second toList) . flip runStateT mempty . runPureLogger+runPureLog = fmap (second toList) . usingStateT mempty . runPureLogger -- | Logs all 'LogEvent'`s from given list. This function supposed to -- be used after 'runPureLog'.@@ -95,7 +93,7 @@ newtype NamedPureLogger m a = NamedPureLogger { runNamedPureLogger :: PureLogger (LoggerNameBox m) a- } deriving (Functor, Applicative, Monad, MonadState (DL.DList LogEvent),+ } deriving (Functor, Applicative, Monad, MonadState (Seq LogEvent), MonadThrow, HasLoggerName) instance MonadTrans NamedPureLogger where
src/System/Wlog/Severity.hs view
@@ -17,7 +17,6 @@ import Data.Typeable (Typeable) import Data.Yaml (FromJSON, ToJSON)-import GHC.Generics (Generic) import qualified Data.Set as Set
src/System/Wlog/Terminal.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ViewPatterns #-}- -- | -- Module : System.Wlog.Terminal -- Copyright : (c) Serokell, 2016
test/Test/Wlog/RollingSpec.hs view
@@ -7,8 +7,7 @@ import Universum import Control.Concurrent.Async (mapConcurrently)-import Control.Lens (zoom, (.=), (?=))-import qualified Prelude (read)+import Lens.Micro.Mtl (zoom, (.=), (?=)) import System.Directory (doesFileExist, removeFile) import System.FilePath (takeExtension) import System.IO (hFileSize)@@ -25,11 +24,13 @@ removeAllHandlers, rotationFileHandler, setupLogging, usingLoggerName, whenExist, zoomLogger) +import qualified Prelude (read)+ spec :: Spec spec = do let smaller = modifyMaxSuccess $ const 30 describe "System.Wlog.Roller" $ do- describe "Exception" $ do+ describe "Exception" $ it "throws exception in case of invalid roller params" $ do let wrongRP1 = RotationParameters 0 1 let wrongRP2 = RotationParameters 1 0@@ -103,7 +104,7 @@ run $ writeConcurrentLogs rp linesNum checkFilesNumber checkFilesSize- run $ cleanupFiles+ run cleanupFiles where testLogPath = "logs/patak.log"