logsink (empty) → 0.1.0

raw patch · 7 files changed

+235/−0 lines, 7 filesdep +basedep +hspecdep +hsyslogsetup-changed

Dependencies added: base, hspec, hsyslog, logging-facade, logsink, time

Files

• LICENSE +19/−0
• Setup.lhs +3/−0
• logsink.cabal +47/−0
• src/System/Logging/LogSink/Config.hs +52/−0
• src/System/Logging/LogSink/Core.hs +56/−0
• src/System/Logging/LogSink/Format.hs +57/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,19 @@+Copyright (c) 2015 Zalora South East Asia Pte. Ltd++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.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,47 @@+name:             logsink+version:          0.1.0+synopsis:         A logging framework for Haskell+description:      A logging framework for Haskell+license:          MIT+license-file:     LICENSE+copyright:        (c) Zalora South East Asia Pte. Ltd+maintainer:       Simon Hengel <sol@typeful.net>+build-type:       Simple+cabal-version:    >= 1.10+category:         System++source-repository head+  type: git+  location: https://github.com/zalora/logsink++library+  ghc-options:+      -Wall+  hs-source-dirs:+      src+  exposed-modules:+      System.Logging.LogSink.Config+      System.Logging.LogSink.Core+      System.Logging.LogSink.Format+  build-depends:+      base == 4.*+    , logging-facade+    , hsyslog+    , time+  default-language: Haskell2010++test-suite spec+  type:+      exitcode-stdio-1.0+  ghc-options:+      -Wall+  hs-source-dirs:+      test+  main-is:+      Spec.hs+  build-depends:+      base == 4.*+    , logsink+    , logging-facade+    , hspec == 2.*+  default-language: Haskell2010

@@ -0,0 +1,52 @@+module System.Logging.LogSink.Config (+  SinkConfig(..)+, defaultSinkConfig+, LogLevel(..)+, LogTarget(..)+, toLogSink+, setupLogging+) where++import           Control.Applicative+import           System.Exit (exitFailure)+import           System.IO+import           System.Logging.Facade.Sink+import           System.Logging.Facade.Types++import           System.Logging.LogSink.Core+import           System.Logging.LogSink.Format++data LogTarget = StdErr | SysLog+  deriving (Eq, Show)++data SinkConfig = SinkConfig {+  sinkConfigLevel :: LogLevel+, sinkConfigFormat :: String+, sinkConfigTarget :: LogTarget+} deriving (Eq, Show)++defaultSinkConfig :: SinkConfig+defaultSinkConfig = SinkConfig {+  sinkConfigLevel = minBound+, sinkConfigFormat = defaultFormatString+, sinkConfigTarget = StdErr+}++setupLogging :: [SinkConfig] -> IO ()+setupLogging sinks = either die (setLogSink . combine) (mapM toLogSink sinks)++die :: String -> IO a+die err = hPutStrLn stderr err >> exitFailure++toLogSink :: SinkConfig -> Either String LogSink+toLogSink sink = filterByLogLevel (sinkConfigLevel sink) . targetToSink sink <$> parseFormat_ (sinkConfigFormat sink)+  where+    parseFormat_ :: String -> Either String Format+    parseFormat_ fmt = case parseFormat fmt of+      Left err -> Left ("Invalid format " ++ show fmt ++ " (" ++ err ++ ")")+      Right f -> return f++targetToSink :: SinkConfig -> Format -> LogSink+targetToSink sink = case sinkConfigTarget sink of+  StdErr -> stdErrSink+  SysLog -> sysLogSink

@@ -0,0 +1,56 @@+module System.Logging.LogSink.Core (+  Format+, defaultFormat+, stdErrSink+, sysLogSink+, combine+, filterByLogLevel+) where++import           Control.Concurrent.MVar+import           Control.Monad+import           System.IO+import           System.IO.Unsafe+import           System.Logging.Facade.Sink+import           System.Logging.Facade.Types+import           System.Posix.Syslog++import           System.Logging.LogSink.Format++defaultFormat :: Format+defaultFormat =+  let Right format = parseFormat defaultFormatString+  in format++{-# NOINLINE stderrLock #-}+stderrLock :: MVar ()+stderrLock = unsafePerformIO $ newMVar ()++stdErrSink :: Format -> LogSink+stdErrSink format record = do+  s <- format record+  modifyMVar_ stderrLock $ \ () -> hPutStrLn stderr s++sysLogSink :: Format -> LogSink+sysLogSink format record = format record >>= syslog (toPriority $ logRecordLevel record)+  where+    toPriority :: LogLevel -> Priority+    toPriority l = case l of+      TRACE -> Debug+      DEBUG -> Debug+      INFO -> Info+      WARN -> Warning+      ERROR -> Error++combine :: [LogSink] -> LogSink+combine sinks record = do+  forM_ sinks $ \sink -> sink record++filterByLogLevel :: LogLevel -> LogSink -> LogSink+filterByLogLevel level sink+  | level == minBound = sink+  | otherwise = filteringSink+  where+    filteringSink record+      | logRecordLevel record < level = return ()+      | otherwise = sink record

@@ -0,0 +1,57 @@+{-# LANGUAGE RecordWildCards #-}+module System.Logging.LogSink.Format where++import           Control.Applicative+import           Control.Concurrent+import           Data.Char+import           Data.Time.Clock+import           Data.Time.LocalTime ()+import           System.Logging.Facade.Types++type Format = LogRecord -> IO String++defaultFormatString :: String+defaultFormatString = "{level}: {message}"++parseFormat :: String -> Either String Format+parseFormat format = formatNodes <$> parseNodes format++data Node = Level | Message | Timestamp | ThreadId | Literal String+  deriving (Eq, Show)++formatNodes :: [Node] -> LogRecord -> IO String+formatNodes nodes LogRecord{..} = concat <$> mapM evalNode nodes+  where+    evalNode :: Node -> IO String+    evalNode node = case node of+      Level -> return (show logRecordLevel)+      Message -> return logRecordMessage+      Timestamp -> show <$> getCurrentTime+      ThreadId -> show <$> myThreadId+      Literal s -> return s++parseNodes :: String -> Either String [Node]+parseNodes = fmap (filter $ not . isEmpty) . go ""+  where+    isIdChar :: Char -> Bool+    isIdChar c = isAlphaNum c || (c `elem` "-_")++    lookupNode :: String -> Maybe Node+    lookupNode key = lookup key [("level", Level), ("message", Message), ("timestamp", Timestamp), ("thread-id", ThreadId)]++    go :: String -> String -> Either String [Node]+    go acc input = case input of+      ""  -> return [lit acc]+      '{':xs | (key,'}':ys) <- span isIdChar xs -> case lookupNode key of+        Nothing -> Left ("invalid format directive " ++ show key)+        Just node -> do+          nodes <- go "" ys+          return (lit acc : node : nodes)+      x:xs -> go (x:acc) xs++    lit :: String -> Node+    lit acc = (Literal . reverse) acc++    isEmpty :: Node -> Bool+    isEmpty (Literal "") = True+    isEmpty _ = False

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}