log4hs 0.0.4.0 → 0.0.5.0

raw patch · 8 files changed

+556/−240 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• log4hs.cabal +5/−2
• src/Logging.hs +4/−5
• src/Logging/Aeson.hs +30/−1
• src/Logging/Types.hs +18/−2
• test/Logging/AesonSpec.hs +210/−0
• test/Logging/TypesSpec.hs +111/−0
• test/LoggingSpec.hs +177/−0
• test/Spec.hs +1/−230

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 39b8ec0bbe2bdbabb40d4ad5b19d1a0ea0755ec5fe019af3de5f56f1f2b55c1f+-- hash: 6da912ef94ad42318d7758fcdd3d5893c0f3d6c4863cc543e25dd6f91ba71bb2  name:           log4hs-version:        0.0.4.0+version:        0.0.5.0 synopsis:       A python logging style log library description:    Please see the http://hackage.haskell.org/package/log4hs category:       logging@@ -48,6 +48,9 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Logging.AesonSpec+      Logging.TypesSpec+      LoggingSpec       Paths_log4hs   hs-source-dirs:       test

@@ -2,7 +2,7 @@ Module          : Logging Copyright       : (c) 2019 Version Cloud License         : BSD3-Maintainer      : Jorah Gao <gqk007@gmail.com>+Maintainer      : Jorah Gao <log4hs@version.cloud> Stability       : experimental Portability     : portable @@ -37,20 +37,19 @@ @  -__See 'Logging.Aeson' to lean more about decoding json into 'Manager'__+__See "Logging.Aeson" to lean more about decoding json into 'Manager'__ -} module Logging   ( module Logging.Aeson+  , module Logging.Types   , module Logging.Deprecated   , module Logging.Internal   -- ** Logging THs   , module Logging.TH-  -- ** Types-  , module Logging.Types   ) where  import           Logging.Aeson import           Logging.Deprecated import           Logging.Internal   hiding (log) import           Logging.TH-import           Logging.Types      hiding (Filterable (..), Formattable (..))+import           Logging.Types

@@ -43,7 +43,9 @@   {     \"loggers\": {\"root\": {}, \"MyLogger\": {}},     \"handlers\": {\"console\": {}, \"file\": {}},-    \"formatters\": {\"default\": {}, \"simple\": {}}+    \"formatters\": {\"default\": {}, \"simple\": {}},+    \"disabled\": false,+    \"catchUncaughtException\": true,   } @ @@ -94,6 +96,33 @@     \"level\": \"INFO\",     \"filterer\": [],     \"formatter\": \"simple\",+  }+@++__Examples of 'Logger' ('Sink') json__++@+  -- a standard format+  {+    \"level\": \"DEBUG\",+    \"filterer\": [\"Package.Module.Submodule\"],+    \"handlers\": [\"console\"],+    \"propagate\": true,+    \"disabled\": false+  }++  -- this example is equivalent to the first+  {+    \"level\": \"DEBUG\",+    \"filterer\": [\"Package.Module.Submodule\"],+    \"handlers\": ["console"]+  }++  -- another example+  {+    \"level\": \"INFO\",+    \"handlers\": [\"console\", \"file\"],+    \"propagate\": false   } @ -}

@@ -43,6 +43,21 @@   -- |'Level' also known as severity, a higher 'Level' means a bigger 'Int'.+--+-- There are 5 common severity levels:+--+-- [@DEBUG@] Level 10+-- [@INFO@] Level 20+-- [@WARN@] Level 30+-- [@ERROR@] Level 40+-- [@FATAL@] Level 50+--+-- >>> :set -XOverloadedStrings+-- >>> "DEBUG" :: Level+-- DEBUG+-- >>> "DEBUG" == (Level 10)+-- True+-- newtype Level = Level Int deriving (Lift, Eq, Ord)  instance Show Level where@@ -148,7 +163,7 @@ -- [@%(message)s@]    The main message passed to 'logv' 'debug' 'info' .. -- data Formatter = Formatter { fmt     :: String-                           , datefmt :: String+                           , datefmt :: String -- ^ see "Data.Time.Format"                            } deriving (Eq)  instance Default Formatter where@@ -196,7 +211,8 @@                  , filterer  :: Filterer                  , handlers  :: [HandlerT]                  , disabled  :: Bool-                 , propagate :: Bool+                 , propagate :: Bool -- ^ It will pop up until root or the+                                     -- ancestor's propagation is disabled                  }  

@@ -0,0 +1,210 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module Logging.AesonSpec ( spec ) where++import           Control.Monad+import           Data.Aeson+import           Data.Aeson.QQ.Simple  (aesonQQ)+import           Data.Default          (def)+import           Data.List             (intercalate)+import qualified Data.Map              as M+import           Data.Maybe            (fromJust)+import           System.IO+import           System.IO.Unsafe+import           Test.Hspec+import           Test.Hspec.QuickCheck++import           Logging+import           Logging.Aeson++spec :: Spec+spec = levelSpec >> filterSpec >> formatterSpec >> handlerSpec >>+       sinkSpec >>  managerSpec+++levelSpec :: Spec+levelSpec = describe "Level" $ modifyMaxSize (const 1000) $ do+  prop "decode" $ \x -> let v = Level x in (decode $ encode $ show v) == Just v+++filterSpec :: Spec+filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do+  prop "decode" $ \fs ->+    let name = intercalate "." fs+    in (decode $ encode name) == Just (Filter name $ length name)+++formatterSpec :: Spec+formatterSpec = describe "Formatter" $ modifyMaxSize (const 1000) $ do+  prop "decode standard" $ \(fmt, datefmt) ->+    let formatter = Formatter fmt datefmt+        obj = object [("fmt", toJSON fmt), ("datefmt", toJSON datefmt)]+    in (decode $ encode obj) == Just formatter++  prop "decode missing filed" $ \fmt ->+    decode (encode $ object [("fmt", toJSON fmt)]) == Just (def {fmt = fmt})++  prop "decode string" $ \fmt -> decode (encode fmt) == Just (def {fmt = fmt})+++handlerSpec :: Spec+handlerSpec = describe "Handler" $ modifyMaxSize (const 1000) $ do+  it "decode StreamHandler simple" $ do+    StreamHandler{..} <- fromJust $ decode $ encode $+      [aesonQQ|{"type": "StreamHandler"}|]+    stream == stderr `shouldBe` True+    level == def `shouldBe` True+    filterer == [] `shouldBe` True+    formatter == def `shouldBe` True++  it "decode StreamHandler standard" $ do+    StreamHandler{..} <- fromJust $ decode $ encode $+      [aesonQQ|+        {+          "type": "StreamHandler",+          "stream": "stdout",+          "level": "DEBUG",+          "filterer": ["Module.Submodule"],+          "formatter": "default"+        }+      |]++    stream == stdout `shouldBe` True+    level == "DEBUG" `shouldBe` True+    filterer == [Filter "Module.Submodule" 16] `shouldBe` True+    formatter == def {fmt = "default"} `shouldBe` True++  it "decode (formatters -> HandlerT)" $ do+    let simple = def {fmt = "%(logger)s: %(message)s"}+        func = fromJust $ decode $ encode+          [aesonQQ|+            {+              "type": "StreamHandler",+              "level": "DEBUG",+              "filterer": ["Module.Submodule"],+              "formatter": "simple"+            }+          |]++    (HandlerT handler) <- func $ M.singleton ("simple" :: String) simple+    getLevel handler == "DEBUG" `shouldBe` True+    getFilterer handler == [Filter "Module.Submodule" 16] `shouldBe` True+    getFormatter handler == simple `shouldBe` True+++sinkSpec :: Spec+sinkSpec = describe "Sink" $ modifyMaxSize (const 1000) $ do+  it "decode" $ do+    let Sink{..} = fromJust $ decode $ encode $+          [aesonQQ|+            {+              "level": "DEBUG",+              "filterer": ["Module.Submodule"],+              "handlers": ["console"],+              "disabled": false,+              "propagate": true+            }+          |]++    logger `shouldBe` "placeholder"+    level `shouldBe` "DEBUG"+    filterer == [Filter "Module.Submodule" 16] `shouldBe` True+    length handlers `shouldBe` 0+    disabled `shouldBe` False+    propagate `shouldBe` True++  it "decode (logger -> handlers -> sink)" $ do+    let handlerMap = M.fromList [ ("console", HandlerT stderrHandler)+                                , ("file" :: String, HandlerT stderrHandler)+                                ]+        func = fromJust $ decode $ encode $+              [aesonQQ|+                {+                  "level": "INFO",+                  "filterer": ["Module.Submodule"],+                  "handlers": ["console", "file"]+                }+              |]+        Sink{..} = func ("MyLogger" :: String) handlerMap++    logger `shouldBe` "MyLogger"+    level `shouldBe` "INFO"+    filterer == [Filter "Module.Submodule" 16] `shouldBe` True+    length handlers `shouldBe` 2 -- deep test handlers+    disabled `shouldBe` False+    propagate `shouldBe` False+++managerSpec :: Spec+managerSpec = describe "Manager" $ modifyMaxSize (const 1000) $ do+  it "decode" $ do+    let Manager{..} = manager_++    length sinks `shouldBe` 1+    M.member "MyLogger" sinks `shouldBe` True+    disabled `shouldBe` False+    catchUncaughtException `shouldBe` True++  it "decode root" $ do+    let Sink{..} = root manager_++    logger `shouldBe` ""+    level `shouldBe` "DEBUG"+    disabled `shouldBe` False+    propagate `shouldBe` False+    length filterer `shouldBe` 0+    length handlers `shouldBe` 1++  it "decode sinks" $ do+    let Sink{..} = (sinks manager_) M.! "MyLogger"++    logger `shouldBe` "MyLogger"+    level `shouldBe` "INFO"+    propagate `shouldBe` False+    disabled `shouldBe` False+    length filterer `shouldBe` 1+    filterer == [Filter "MyLogger.Main" 13] `shouldBe` True+    length handlers `shouldBe` 2+++-- Decoding manager globally, or it will throw file resouse busy error+manager_ :: Manager+{-# NOINLINE manager_ #-}+manager_ = unsafePerformIO $ fromJust $ decode $ encode [aesonQQ|{+  "catchUncaughtException": true,+  "loggers": {+      "root": {+        "level": "DEBUG",+        "handlers": ["console"],+        "propagate": false+      },+      "MyLogger": {+        "level": "INFO",+        "filterer": ["MyLogger.Main"],+        "handlers": ["console", "file"],+        "propagate": false+      }+    },+    "handlers": {+      "console": {+        "type": "StreamHandler",+        "stream": "stderr",+        "level": "DEBUG",+        "formatter": "default"+      },+      "file": {+        "type": "FileHandler",+        "level": "INFO",+        "formatter": "default",+        "file": "./default.log"+      }+    },+    "formatters": {+      "default": {+        "fmt": "%(asctime)s - %(level)s - %(logger)s:%(lineno)d] %(message)s"+      }+    }+}|]

@@ -0,0 +1,111 @@+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE StandaloneDeriving #-}++module Logging.TypesSpec ( spec ) where++import           Data.Default+import           Data.String           (fromString)+import           Data.Time.Clock+import           Data.Time.Format      as TF+import           Data.Time.LocalTime+import           System.FilePath+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Text.Printf++import           Logging.Types++spec :: Spec+spec = levelSpec >> formatterSpec+++levelSpec :: Spec+levelSpec = describe "Level" $ modifyMaxSize (const 1000) $ do+  prop "read and show" $ \x -> (read . show) (Level x) == (Level x)+  prop "overload string" $ \x -> fromString (show (Level x)) == (Level x)+++formatterSpec :: Spec+formatterSpec = describe "Formatter" $ modifyMaxSize (const 1000) $ do+    -- one field only+    fmtProp "%(logger)s" "LogRecord's logger record" loggerFmt+    fmtProp "%(level)s" "LogRecord's level record" levelFmt+    fmtProp "%(message)s" "LogRecord's message record" message+    fmtProp "%(pathname)s" "LogRecord's filename (dir) record" pathnameFmt+    fmtProp "%(filename)s" "LogRecord's filename (no dir) record" filenameFmt+    fmtProp "%(module)s" "LogRecord's modulename record" modulename+    fmtProp "%(lineno)d" "LogRecord's lineno record" $ show . lineno+    fmtProp "%(created)f"+          "LogRecord's created (decimal second timestamp) record"+          createdFmt+    fmtProp "%(msecs)d"+          "LogRecord's created (millisecond timestamp) record"+          msecsFmt+    dateProp "%(asctime)s" "%Y-%m-%dT%H:%M:%S"+              "LogRecord's created (human friendly) record"+              asctimeFmt+    -- mixed fields+    dateProp+      "%(asctime)s - %(level)s - %(logger)s" "%Y-%m-%dT%H:%M:%S"+      "LogRecord's created (human friendly) - level - logger records"+      asctimeLevelLoggerFmt+    fmtProp "%(pathname)s/%(filename)s" "LogRecord's filename (/ split) record"+      pathnameFilenameFmt+    fmtProp "%(lineno)d] %(message)s" "LogRecord's lineno] message records"+      linenoMessageFmt+  where+    fmtProp :: String -> String -> (LogRecord -> String)+          -> SpecWith (Arg Property)+    fmtProp fmt desc manualFmt = prop (printf "format %s to %s" fmt desc) $+      \rcd -> format (def {fmt = fmt}) rcd == manualFmt rcd++    dateProp :: String -> String -> String -> (LogRecord -> String)+              -> SpecWith (Arg Property)+    dateProp fmt datefmt desc manualFmt =+      prop (printf "format %s(%s) to %s" fmt datefmt desc) $+        \rcd -> format (Formatter fmt datefmt) rcd == manualFmt rcd++    loggerFmt = \LogRecord{..} -> logger+    levelFmt = \LogRecord{..} -> show level+    pathnameFmt = takeDirectory . filename+    filenameFmt = takeFileName . filename+    createdFmt = (printf "%f") . zt2timestamp . created+    msecsFmt = show . zt2millisecs . created+    asctimeFmt = TF.formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" . created+    asctimeLevelLoggerFmt rcd =+      asctimeFmt rcd ++ " - " ++ (levelFmt rcd) ++ " - " ++(loggerFmt rcd)+    pathnameFilenameFmt rcd = pathnameFmt rcd ++ "/" ++ (filenameFmt rcd)+    linenoMessageFmt rcd = (show $ lineno rcd) ++ "] " ++ (message rcd)+++deriving instance Show LogRecord+++instance Arbitrary LogRecord where+  arbitrary = LogRecord+           <$> arbitrary+           <*> (Level <$> arbitrary)+           <*> arbitrary+           <*> arbitrary+           <*> arbitrary+           <*> arbitrary+           <*> arbitrary+           <*> (((`addZonedTime` zeroTime) . toEnum) <$> arbitrary)+++addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime+addZonedTime ndt zt@(ZonedTime _ tz) =+  utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt++diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime+diffZonedTime zt1 zt2 = diffUTCTime (zonedTimeToUTC zt1) (zonedTimeToUTC zt2)++zeroTime :: ZonedTime+zeroTime = read "1970-01-01 00:00:00"++zt2timestamp :: ZonedTime -> Double+zt2timestamp zt = fromRational $ toRational $ diffZonedTime zt zeroTime++zt2millisecs :: ZonedTime -> Integer+zt2millisecs zt = round $ zt2timestamp zt * 1000

@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module LoggingSpec ( spec ) where++import           Control.Concurrent.MVar+import           Control.Monad+import           Data.Default            (def)+import           Data.List               (intercalate)+import qualified Data.Map                as M+import           Data.Word+import           Prelude                 hiding (error)+import           System.IO+import           System.IO.Unsafe        (unsafePerformIO)+import           System.Process          (createPipe)+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck         hiding (run)+import qualified Test.QuickCheck.Monadic as Q++import           Logging++spec :: Spec+spec = basicSpec >> formatSpec >> filterSpec >> propagateSpec+++basicSpec :: Spec+basicSpec = describe "Basic" $ modifyMaxSize (const 1000) $ do+  prop "log to root" $ \(PrintableString msg) ->+    runLog "" "DEBUG" msg "debug" (== msg)+  prop "log to Log4hs" $ \(PrintableString msg) ->+    runLog "Log4hs" "INFO" msg "debug" (== msg)+  prop "log to Log4hs.Json" $ \(PrintableString msg) ->+    runLog "Log4hs.Json" "WARN" msg "debug" (== msg)+  prop "disabled some" $ \(PrintableString msg) level ->+    runLog "Log10000hs" level msg "debug" (== "")+  prop "disabled all" $ \(PrintableString msg) loggers level ->+    let logger = intercalate "." $ [getPrintableString x | x <- loggers]+    in runDisabledLog logger level msg+++formatSpec :: Spec+formatSpec = describe "Format" $ modifyMaxSize (const 1000) $ do+  prop "simple" $ \(PrintableString msg) ->+    runLog "" "DEBUG" msg "debug" (== msg)+  prop "logger" $ \(PrintableString msg) (Log4hsLogger logger) -> do+    runLog logger "WARN" msg "info" (== logger ++ ": " ++ msg)+  prop "level" $ \(PrintableString msg) (Log4hsLogger logger) fmtlevel ->+    let (Log4hsHighLevel level) = fmtlevel+        out = logger ++ " " ++ (show level) ++ "] " ++ msg+    in runLog logger level msg "error" (== out)+++filterSpec :: Spec+filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do+  prop "root sink && debug handler" $ \(PrintableString msg) level ->+    runLog "" level msg "debug" $ (== if level >= "DEBUG" then msg else "")+  prop "Log4hs sink && info handler" $ \(PrintableString msg) level ->+    let out = if level >= "INFO" then "Log4hs: " ++ msg else ""+    in runLog "Log4hs" level msg "info" $ (== out)+  prop "Log4hs.Json sink && error handler" $ \(PrintableString msg) level ->+    let out = if level >= "ERROR"+                then "Log4hs.Json " ++ (show level) ++ "] " ++ msg+                else ""+    in runLog "Log4hs.Json" level msg "error" $ (== out)+  prop "handler's filterer" $ \(PrintableString msg) (Small v)->+    let logger = "Log4hs.V" ++ (show v)+        out = if v == (3 :: Word8) then logger ++ ": " ++ msg else ""+    in runLog logger "INFO" msg "infov3" (== out)+++propagateSpec :: Spec+propagateSpec = describe "Propagate" $ modifyMaxSize (const 1000) $ do+  prop "to root (real)" $ \(PrintableString msg) ->+    runLog "Log8hs" "WARN" msg "debug" $ (== msg)+  prop "to root (virtual)" $ \(PrintableString msg) ->+    runLog "Log0hs" "WARN" msg "debug" $ (== msg)+  prop "to parent (real)" $ \(PrintableString msg) ->+    runLog "Log4hs.Json" "WARN" msg "info" $ (== "Log4hs.Json: " ++ msg)+  prop "to parent (virtual)" $ \(PrintableString msg) ->+    runLog "Log4hs.Ini" "WARN" msg "info" $ (== "Log4hs.Ini: " ++ msg)+  prop "to grandparent (real)" $ \(PrintableString msg) ->+    runLog "Log8hs.Json" "WARN" msg "debug" $ (== msg)+  prop "to grandparent (virtual)" $ \(PrintableString msg) ->+    runLog "Log0hs.Json" "WARN" msg "debug" $ (== msg)+  prop "disabled" $ \(PrintableString msg) ->+    runLog "Log4hs" "FATAL" msg "fatal" $ (== "")+++runLog :: Logger -> Level -> String -> String -> (String -> Bool) -> Property+runLog logger level msg stream test = Q.monadicIO $ do+  out <- Q.run $ createManager False >>= \(mgr, streams) -> run mgr $+    $(logv) logger level msg  >> hTryGetLine (streams M.! stream)+  Q.assert $ test out+++runDisabledLog :: Logger -> Level -> String -> Property+runDisabledLog logger level msg = Q.monadicIO $ do+  outs <- Q.run $ createManager True >>= \(mgr, streams) -> run mgr $+    $(logv) logger level msg  >> sequence (M.map hTryGetLine streams)+  Q.assert $ M.empty == M.filter (/= "") outs+++createManager :: Bool -> IO (Manager, M.Map String Handle)+createManager disabled = do+  debugPh <- createPipeHandler "DEBUG" [] (formatters M.! "simple")+  infoPh <- createPipeHandler "INFO" [] (formatters M.! "logger")+  infov3Ph <- createPipeHandler "INFO" ["Log4hs.V3"] (formatters M.! "logger")+  errorPh <- createPipeHandler "ERROR" [] (formatters M.! "level")+  fatalPh <- createPipeHandler "FATAL" [] (formatters M.! "logger")++  let root = Sink "" "DEBUG" [] [fst debugPh, fst fatalPh] False False+      handlers = [fst debugPh, fst infoPh, fst infov3Ph, fst errorPh]+      log4hs = Sink "Log4hs" "INFO" [] handlers False False+      log4hsJson = Sink "Log4hs.Json" "WARN" [] [] False True+      log4hsYaml = Sink "Log4hs.Yaml" "WARN" [] [] False True+      log8hs = Sink "Log8hs" "INFO" [] [] False True+      log8hsJson = Sink "Log8hs.Json" "INFO" [] [] False True+      log10000hs = Sink "Log8hs.Json" "INFO" [] [fst debugPh] True False+      sinks = M.fromList [ ("Log4hs", log4hs)+                         , ("Log4hs.Json", log4hsJson)+                         , ("Log4hs.Yaml", log4hsYaml)+                         , ("Log8hs", log8hs)+                         , ("Log8hs.Json", log8hsJson)+                         , ("Log10000hs", log10000hs)+                         ]+      streams = M.fromList $ [ ("debug", snd debugPh)+                             , ("info", snd infoPh)+                             , ("infov3", snd infov3Ph)+                             , ("error", snd errorPh)+                             , ("fatal", snd fatalPh)+                             ]+  return (Manager root sinks disabled False, streams)+++formatters :: M.Map String Formatter+formatters = M.fromList+  [ ("simple", def {fmt = "%(message)s"})+  , ("logger", def {fmt = "%(logger)s: %(message)s"})+  , ("level", def {fmt = "%(logger)s %(level)s] %(message)s"})+  ]+++createPipeHandler :: Level -> Filterer -> Formatter -> IO (HandlerT, Handle)+createPipeHandler level filterer formatter = do+  lock <- newMVar ()+  (read, write) <- createPipe+  hSetEncoding read utf8+  hSetEncoding write utf8+  return $ ( HandlerT $ StreamHandler write level filterer formatter lock+           , read+           )+++hTryGetLine :: Handle -> IO String+hTryGetLine hdl = do+  ready <- hReady hdl+  if ready then hGetLine hdl else return ""+++instance Arbitrary Level where+  arbitrary = Level <$> arbitrary+++newtype Log4hsLogger = Log4hsLogger Logger deriving Show++instance Arbitrary Log4hsLogger where+  arbitrary = elements $+    map Log4hsLogger ["Log4hs", "Log4hs.Json", "Log4hs.Yaml"]+++newtype Log4hsHighLevel = Log4hsHighLevel Level deriving Show++instance Arbitrary Log4hsHighLevel where+  arbitrary = elements $ map Log4hsHighLevel ["ERROR", "FATAL", Level 100]

@@ -1,230 +1,1 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}--import           Control.Concurrent.MVar-import           Control.Monad-import           Data.Aeson                 as A-import           Data.Aeson.QQ.Simple       (aesonQQ)-import           Data.Default               (def)-import           Data.List                  (intercalate, lines)-import qualified Data.Map                   as M-import           Data.String                (fromString)-import           Data.Time.LocalTime        (ZonedTime)-import           System.FilePath-import           System.IO-import           System.Process             (createPipe)-import           Test.Hspec-import           Test.Hspec.Core.QuickCheck (modifyMaxSize)-import           Test.QuickCheck-import qualified Test.QuickCheck.Monadic    as QC--import           Logging-import           Logging.Aeson--main :: IO ()-main = hspec $ do-  describe "Level" $-    modifyMaxSize (const 1000) $ do-      it "read is reverse to show" $-        property $ \x -> (read . show) (Level x) == (Level x)-      it "overload string is equivalent to read" $-        property $ \x -> fromString (show (Level x)) == (Level x)--  describe "Formatter" $ do-    modifyMaxSize (const 1000) $ do-      it "format \"%(logger)s\" to LogRecord's logger record" $-        testFormatter (def {fmt = "%(logger)s"}) $ \LogRecord{..} -> logger-      it "format \"%(level)s\" to LogRecord's level record" $-        testFormatter (def {fmt = "%(level)s"}) $ \LogRecord{..} -> show level-      it "format \"%(message)s\" to LogRecord's message record" $-        testFormatter (def {fmt = "%(message)s"}) message-      it "format \"%(pathname)s\" to LogRecord's filename record's directory" $-        testFormatter (def {fmt = "%(pathname)s"}) $-          \LogRecord{..} -> takeDirectory filename-      it "format \"%(filename)s\" to LogRecord's filename record's base filename" $-        testFormatter (def {fmt = "%(filename)s"}) $-          \LogRecord{..} -> takeFileName filename-      it "format \"%(module)s\" to LogRecord's modulename record" $-        testFormatter (def {fmt = "%(module)s"}) modulename--    it "format \"%(lineno)d\" to LogRecord's lineno record" $-      testFormatter (def {fmt = "%(lineno)d"}) (show . lineno)--    it "format \"%(created)f\" to LogRecord's create time (second timestamp)" $-      testFormatter (def {fmt = "%(created)f"}) (const (show (1 :: Double)))--    it "format \"%(asctime)f\" to LogRecord's create time (human readdable)" $-      testFormatter-        (def {fmt = "%(asctime)s", datefmt="%Y-%m-%dT%H:%M:%S"})-        (const "1970-01-01T00:00:01")--    it "format \"%(msecs)d\" to LogRecord's create time (millisecond timestamp)" $-      testFormatter (def {fmt = "%(msecs)d"}) (const "1000" )--  describe "Manager" $-    modifyMaxSize (const 1000) $ do-      it "parse json to Manager" testJsonToManager-      it "run logging environment && logging THs" testRunLogging---makeRecord :: (Logger, Int, String, FilePath, String, String, Int) -> LogRecord-makeRecord (logger, level, message, file, package, modulename, line) =-  LogRecord { logger = replaceLine logger-            , level = Level level-            , message = replaceLine message-            , filename = replaceLine file-            , packagename = replaceLine package-            , modulename = replaceLine modulename-            , lineno = line-            , created = created-            }-  where-    created :: ZonedTime-    created = read "1970-01-01 00:00:01"-    -- replace '\n' with "<newline>" flag, or it will affect test,-    -- it works fine in normal situation.-    replaceLine :: String -> String-    replaceLine = intercalate "<newline>" . lines----testFormatter :: Formatter -> (LogRecord -> String) -> Property-testFormatter formatter format = property $ \x -> QC.monadicIO $ do-  (readEnd, writeEnd) <- QC.run $ createPipe-  QC.run $ hSetEncoding writeEnd utf8-  QC.run $ hSetEncoding readEnd utf8-  let rcd = makeRecord x-      handler = stderrHandler {formatter = formatter, stream = writeEnd }-  QC.run $ handle handler rcd-  msg <- QC.run $ hGetLine readEnd-  QC.assert (msg == format rcd)--testJsonToManager :: IO ()-testJsonToManager = (sequence $ A.fromJSON managerJson) >>= \result ->-    case result of-      A.Error msg               -> expectationFailure msg-      A.Success mgr@Manager{..} -> do-        -- root-        testSink "root" root-        -- sinks-        length sinks `shouldBe` 1-        M.member "MyLogger" sinks `shouldBe` True-        testSink "MyLogger" $ sinks M.! "MyLogger"-  where-    testSink :: Logger -> Sink -> IO ()-    testSink "root" Sink{..} = do-      logger `shouldBe` ""-      level `shouldBe` "DEBUG"-      propagate `shouldBe` False-      disabled `shouldBe` False-      length filterer `shouldBe` 0-      length handlers `shouldBe` 1-      void $ forM_ handlers testHandler-    testSink "MyLogger" Sink{..} = do-      logger `shouldBe` "MyLogger"-      level `shouldBe` "INFO"-      propagate `shouldBe` False-      disabled `shouldBe` False-      length filterer `shouldBe` 1-      filterer == [Filter "MyLogger.Main" 13] `shouldBe` True-      length handlers `shouldBe` 2-      void $ forM_ handlers testHandler--    testHandler :: HandlerT -> IO ()-    testHandler (HandlerT hdl) = do-      let fmt = "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s"-      getFilterer hdl == [] `shouldBe` True-      getFormatter hdl == def {fmt = fmt} `shouldBe` True-      getLevel hdl `elem` ["DEBUG", "INFO"] `shouldBe` True--    managerJson = [aesonQQ|{-      "loggers": {-          "root": {-            "level": "DEBUG",-            "handlers": ["console"],-            "propagate": false-          },-          "MyLogger": {-            "level": "INFO",-            "filterer": ["MyLogger.Main"],-            "handlers": ["console", "file"],-            "propagate": false-          }-        },-        "handlers": {-          "console": {-            "type": "StreamHandler",-            "stream": "stderr",-            "level": "DEBUG",-            "formatter": "defaultFormatter"-          },-          "file": {-            "type": "FileHandler",-            "level": "INFO",-            "formatter": "defaultFormatter",-            "file": "./default.log"-          }-        },-        "formatters": {-          "defaultFormatter": {-            "fmt": "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s"-          }-        }-    }|]---testRunLogging :: IO ()-testRunLogging = do-    (mgr, consoleReadEnd, fileReadEnd) <- prepare-    let msg = "this is a test msg"-    run mgr $ do-      -- root-      forM ["debug", "info", "warn", "error", "fatal"] $ \logx -> do-        runLog logx "" msg [(consoleReadEnd, msg), (fileReadEnd, "")]--      -- MyLogger (filter)-      forM ["debug", "info", "warn", "error", "fatal"] $ \logx -> do-        runLog logx "MyLogger" msg [(consoleReadEnd, ""), (fileReadEnd, "")]--      -- debug MyLogger.Main-      runLog "debug" "MyLogger.Main" msg [(consoleReadEnd, ""), (fileReadEnd, "") ]-      -- the rest logs of MyLogger.Main-      forM ["info", "warn", "error", "fatal"] $ \logx -> do-        runLog logx "MyLogger.Main" msg [(consoleReadEnd, msg), (fileReadEnd, msg)]--      return ()-  where-    prepare :: IO (Manager, Handle, Handle)-    prepare = do-      (consoleReadEnd, consoleWriteEnd) <- createPipe-      hSetEncoding consoleReadEnd utf8-      hSetEncoding consoleWriteEnd utf8--      (fileReadEnd, fileWriteEnd) <- createPipe-      hSetEncoding fileReadEnd utf8-      hSetEncoding fileWriteEnd utf8--      console <- StreamHandler consoleWriteEnd "DEBUG" [] def <$> newMVar ()-      file <- StreamHandler fileWriteEnd "INFO" [] def <$> newMVar ()--      let root = Sink "" "DEBUG" [] [HandlerT console] False False-          myLogger = Sink "MyLogger" "INFO" ["MyLogger.Main"] [HandlerT console, HandlerT file] False False-          sinks = M.fromList [("MyLogger", myLogger)]-      return (Manager root sinks False True, consoleReadEnd, fileReadEnd)--    runLog :: String -> String -> String -> [(Handle, String)] -> IO ()-    runLog logx logger msg asserts = do-      case logx of-        "debug" -> $(debug) logger msg-        "info"  -> $(info) logger msg-        "warn"  -> $(warn) logger msg-        "error" -> $(Logging.error) logger msg-        "fatal" -> $(fatal) logger msg-        _       -> expectationFailure "unknown log function"--      void $ forM_ asserts $ \(handle, value) -> do-        ready <- hReady handle -- pipe read end will wait until write end has been written-        real <- if ready then hGetLine handle else return ""-        real `shouldBe` value+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}