katip 0.3.0.0 → 0.3.1.0

raw patch · 8 files changed

+399/−11 lines, 8 filesdep +tasty-goldendep ~aesondep ~bytestringdep ~microlensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tasty-golden

Dependency ranges changed: aeson, bytestring, microlens

API changes (from Hackage documentation)

Files

• README.md +1/−0
• changelog.md +5/−0
• katip.cabal +7/−4
• src/Katip/Format/Time.hs +213/−0
• src/Katip/Monadic.hs +11/−2
• src/Katip/Scribes/Handle.hs +2/−3
• test/Katip/Tests/Scribes/Handle.hs +158/−2
• test/Main.hs +2/−0

@@ -81,3 +81,4 @@ * [Ozgun Ataman](https://github.com/ozataman) * [Michael Xavier](https://github.com/MichaelXavier) * [Doug Beardsley](https://github.com/mightybyte)+* [Leonid Onokhov](https://github.com/sopvop)

@@ -1,3 +1,8 @@+0.3.1.0+=======+* Add support for aeson 1.0.x+* Add Katip.Format.Time module and use much more efficient time formatting code in the Handle scribe.+ 0.3.0.0 ======= * Switch from `regex-tdfa-rc` to `regex-tdfa`.

@@ -1,5 +1,5 @@ name:                katip-version:             0.3.0.0+version:             0.3.1.0 synopsis:            A structured logging framework. description:   Katip is a structured logging framework. See README.md for more details.@@ -37,6 +37,7 @@   exposed-modules:     Katip     Katip.Core+    Katip.Format.Time     Katip.Monadic     Katip.Scribes.Handle @@ -51,7 +52,7 @@     OverloadedStrings    build-depends: base >=4.5 && <5-               , aeson >=0.6 && <0.12+               , aeson >=0.6 && <1.1                , auto-update >= 0.1 && < 0.2                , bytestring >= 0.9 && < 0.11                , containers >=0.4 && <0.6@@ -63,7 +64,6 @@                , template-haskell >= 2.8 && < 2.12                , text >= 0.11 && <1.3                , time >= 1 && < 1.7-               , time-locale-compat >= 0.1.0.1 && < 0.2                , transformers >= 0.3 && < 0.6                , transformers-compat                , unix >= 2.5 && < 2.8@@ -90,18 +90,21 @@   build-depends: base                , katip                , aeson+               , bytestring                , tasty >= 0.10.1.2+               , tasty-golden                , tasty-hunit                , tasty-quickcheck                , quickcheck-instances                , template-haskell                , text                , time+               , time-locale-compat >= 0.1.0.1 && < 0.2                , temporary                , directory                , regex-tdfa                , unordered-containers-+               , microlens  benchmark bench   type: exitcode-stdio-1.0

@@ -0,0 +1,213 @@+-- | Time and memory efficient time encoding helper functions.+--+module Katip.Format.Time+    ( formatAsLogTime+    , formatAsIso8601+    ) where++import           Control.Monad.ST        (ST)++import           Data.Int                (Int64)+import qualified Data.Text.Array         as TA+import           Data.Text               (Text)+import           Data.Text.Internal      (Text(..))+import           Data.Time               (UTCTime(..), toGregorian, Day, DiffTime)+import           Data.Word               (Word16)+import           Unsafe.Coerce           (unsafeCoerce)++-- Note: All functions here are optimized to never allocate anything+-- on heap. At least on ghc 8.0.1 no extra strictness annotations are+-- seem to be needed.+--+-- Exported functions are INLINEABLE+++-- | Format 'UTCTime' into a short human readable format.+--+-- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012+-- "2016-01-23 01:23:45"+--+formatAsLogTime :: UTCTime -> Text+formatAsLogTime (UTCTime day time) = toText $ TA.run2 $ do+     buf <- TA.new 19 -- length "2016-10-20 12:34:56"+     _ <- writeDay buf 0 day+     TA.unsafeWrite buf 10 0x20 -- space+     _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)+     return (buf, 19)+  where+     toText (arr, len) = Text arr 0 len++{-# INLINEABLE formatAsLogTime #-}++-- | Format 'UTCTime' into a Iso8601 format.+--+--  Note that this function may overcommit up to 12*2 bytes, depending+--  on sub-second precision. If this is an issue, make a copy with a+--  'Data.Text.copy'.+--+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012+-- "2016-11-23T01:23:45.123456789012Z"+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123+-- "2016-01-23T01:23:45.123Z"+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025+-- "2016-01-23T01:23:45Z"++--+formatAsIso8601 :: UTCTime -> Text+formatAsIso8601 (UTCTime day time) = toText $ TA.run2 $ do+   buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"+   _ <- writeDay buf 0 day+   TA.unsafeWrite buf  10  0x54 -- T+   next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)+   TA.unsafeWrite buf next 0x5A -- Z+   return (buf, next+1)+  where+     toText (arr, len) = Text arr 0 len++{-# INLINEABLE formatAsIso8601 #-}++-- | Writes the @YYYY-MM-DD@ part of timestamp+writeDay :: TA.MArray s -> Int -> Day -> ST s Int+writeDay buf off day =+  do+    TA.unsafeWrite buf (off + 0) (digit y1)+    TA.unsafeWrite buf (off + 1) (digit y2)+    TA.unsafeWrite buf (off + 2) (digit y3)+    TA.unsafeWrite buf (off + 3) (digit y4)+    TA.unsafeWrite buf (off + 4) 0x2d -- dash+    TA.unsafeWrite buf (off + 5) m1+    TA.unsafeWrite buf (off + 6) m2+    TA.unsafeWrite buf (off + 7) 0x2d -- dash+    TA.unsafeWrite buf (off + 8) d1+    TA.unsafeWrite buf (off + 9) d2+    return (off + 10)+  where+    (yr,m,d) = toGregorian day+    (y1, ya) = fromIntegral (abs yr) `quotRem` 1000+    (y2, yb) = ya `quotRem` 100+    (y3, y4) = yb `quotRem` 10+    T m1 m2  = twoDigits m+    T d1 d2  = twoDigits d+{-# INLINE writeDay #-}++-- | Write time of day, optionally with sub seconds+writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int+writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) =+  do++    TA.unsafeWrite buf  off      h1+    TA.unsafeWrite buf (off + 1) h2+    TA.unsafeWrite buf (off + 2) 0x3A -- colon+    TA.unsafeWrite buf (off + 3) m1+    TA.unsafeWrite buf (off + 4) m2+    TA.unsafeWrite buf (off + 5) 0x3A -- colon+    TA.unsafeWrite buf (off + 6) s1+    TA.unsafeWrite buf (off + 7) s2+    if doSubSeconds && frac /= 0+    then writeFracSeconds buf (off + 8) frac+    else return (off + 8)+  where+   T h1 h2 = twoDigits hh+   T m1 m2 = twoDigits mm+   T s1 s2 = twoDigits (fromIntegral real)+   (real,frac) = ss `quotRem` pico+   pico       = 1000000000000 -- number of picoseconds  in 1 second+++writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int+writeFracSeconds buf off frac =+  do+    TA.unsafeWrite buf off 0x2e -- period+    if mills == 0+    then do+      writeTrunc6 buf (off + 1) (fromIntegral mics)+    else do+      writeDigit6 buf (off + 1) (fromIntegral mics)+      writeTrunc6 buf (off + 7) (fromIntegral mills)++  where+    (mics, mills)  = frac `quotRem` micro+    micro          = 1000000 -- number of microseconds in 1 second+++writeDigit6 :: TA.MArray s -> Int -> Int -> ST s ()+writeDigit6 buf off i =+  do+    writeDigit3 buf off f1+    writeDigit3 buf (off+3) f2+  where+   (f1, f2) = i `quotRem` 1000++{-# INLINE writeDigit6 #-}++writeDigit3 :: TA.MArray s -> Int -> Int -> ST s ()+writeDigit3 buf off i =+  do+    TA.unsafeWrite buf off (digit d1)+    TA.unsafeWrite buf (off+1) (digit d2)+    TA.unsafeWrite buf (off+2) (digit d3)+  where+    (d1, d) = i `quotRem` 100+    (d2, d3) = d `quotRem` 10++{-# INLINE writeDigit3 #-}++writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int+writeTrunc6 buf off i =+  if f2 == 0+    then writeTrunc3 buf off f1+    else do+      writeDigit3 buf off f1+      writeTrunc3 buf (off+3) f2+  where+   (f1, f2) = i `quotRem` 1000++{-# INLINE writeTrunc6 #-}+++writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int+writeTrunc3 buf off i+    | d == 0 = do+        TA.unsafeWrite buf off (digit d1)+        return (off+1)+    | d3 == 0 = do+        TA.unsafeWrite buf off (digit d1)+        TA.unsafeWrite buf (off+1) (digit d2)+        return (off+2)++    | otherwise = do+        TA.unsafeWrite buf off (digit d1)+        TA.unsafeWrite buf (off+1) (digit d2)+        TA.unsafeWrite buf (off+2) (digit d3)+        return (off+3)+  where+    (d1, d) = i `quotRem` 100+    (d2, d3) = d `quotRem` 10++{-# INLINE writeTrunc3 #-}+++-- Following code was adapted from aeson package.+--+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3++data T = T {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16++twoDigits :: Int -> T+twoDigits a     = T (digit hi) (digit lo)+  where (hi,lo) = a `quotRem` 10++digit :: Int -> Word16+digit x = fromIntegral (x + 48)+++data TimeOfDay64 = TOD {-# UNPACK #-} !Int+                       {-# UNPACK #-} !Int+                       {-# UNPACK #-} !Int64++diffTimeOfDay64 :: DiffTime -> TimeOfDay64+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s+  where (h,mp) = fromIntegral pico `quotRem` 3600000000000000+        (m,s)  = mp `quotRem` 60000000000000+        pico   = unsafeCoerce t :: Integer

@@ -315,7 +315,8 @@  ------------------------------------------------------------------------------- -- | Append a namespace segment to the current namespace for the given--- monadic action, then restore the previous state afterwards.+-- monadic action, then restore the previous state+-- afterwards. katipAddNamespace     :: (Monad m)     => Namespace@@ -327,7 +328,15 @@  ------------------------------------------------------------------------------- -- | Append some context to the current context for the given monadic--- action, then restore the previous state afterwards.+-- action, then restore the previous state afterwards. Important note:+-- be careful using this in a loop. If you're using something like+-- 'forever' or 'replicateM_' that does explicit sharing to avoid a+-- memory leak, youll be fine as it will *sequence* calls to+-- 'katipAddNamespace', so each loop will get the same context+-- added. If you instead roll your own recursion and you're recursing+-- in the action you provide, you'll instead accumulate tons of+-- redundant contexts and even if they all merge on log, they are+-- stored in a sequence and will leak memory. katipAddContext     :: ( LogItem i        , Monad m

@@ -13,12 +13,11 @@ import           Data.Text               (Text) import           Data.Text.Lazy.Builder import           Data.Text.Lazy.IO       as T-import           Data.Time-import qualified Data.Time.Locale.Compat as LC import           System.IO import           System.IO.Unsafe        (unsafePerformIO) ------------------------------------------------------------------------------- import           Katip.Core+import           Katip.Format.Time       (formatAsLogTime) -------------------------------------------------------------------------------  @@ -83,7 +82,7 @@     maybe mempty (brackets . fromString . locationToString) _itemLoc <>     fromText " " <> (unLogStr _itemMessage)   where-    nowStr = fromString $ formatTime LC.defaultTimeLocale "%Y-%m-%d %H:%M:%S" _itemTime+    nowStr = fromText (formatAsLogTime _itemTime)     ks = map brackets $ getKeys verb _itemPayload     renderSeverity' s = case s of       EmergencyS -> red $ renderSeverity s

@@ -6,17 +6,26 @@ ------------------------------------------------------------------------------- import           Control.Monad import           Data.Aeson+import qualified Data.ByteString.Lazy       as BL import           Data.Monoid-import           Data.Text        (Text)-import qualified Data.Text.IO     as T+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import qualified Data.Text.IO               as T+import qualified Data.Text.Lazy             as LT+import qualified Data.Text.Lazy.Builder     as LT+import           Data.Time+import           Language.Haskell.TH.Syntax (Loc (..))+import           Lens.Micro                 ((.~)) import           System.Directory import           System.IO import           System.IO.Temp import           Test.Tasty+import           Test.Tasty.Golden import           Test.Tasty.HUnit import           Text.Regex.TDFA ------------------------------------------------------------------------------- import           Katip+import           Katip.Scribes.Handle -------------------------------------------------------------------------------  @@ -31,6 +40,10 @@        let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String        let matches = res =~ pat        assertBool (res <> " did not match") matches+  , withResource setupTempFile teardownTempFile $ \setup ->+       goldenVsString "Text-golden"+                      "test/Katip/Tests/Scribes/Handle-text.golden"+                      (setup >>= writeTextLog)   ]  @@ -74,3 +87,146 @@ teardown (_, h, _) = do   chk <- hIsOpen h   when chk $ hClose h++++-- Following code tests Handle scribe output against a golden file.+-- This test will fail on non utf8 locales because golden file is in utf-8.+-- It generates all meaningfull variations of Item, and also tests+-- writing of payload of different Aeson constructors+--+-- Note: currently Handle scribe does not write Array items at all+-------------------------------------------------------------------------------+data AllTypesLogItem = AllTypesLogItem+    { atlText  :: Text+    , atlNum   :: Int+    , atlFloat :: Float+    , atlList  :: [Text]+    , atlSub   :: Maybe DummyLogItem+    }+++instance ToJSON AllTypesLogItem where+  toJSON it = object+    [ "text"     .= atlText it+    , "num"      .= atlNum it+    , "float"    .= atlFloat it+    , "list"     .= atlList it+    , "sub"      .= atlSub it+    ]+++instance ToObject AllTypesLogItem+++instance LogItem AllTypesLogItem where+  payloadKeys _ _ = AllKeys+++-------------------------------------------------------------------------------+theItem :: Item DummyLogItem+theItem = Item (Namespace ["app"])+               (Environment "production")+               (InfoS)+               (ThreadIdText "1337")+               "example"+               7331+               dummyLogItem+               "message"+               (mkUTCTime 2016 6 12 12 34 56)+               (Namespace ["foo"])+               Nothing++genItems :: [Item DummyLogItem]+genItems = concat $+  [ [ itemSeverity .~ s $ theItem+          | s <- [minBound .. maxBound]+    ]+  , [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem+          | t <- [0, 1, 1337, 2147483647]+    ]+  , [ itemHost .~ h $ theItem+          | h <- ["example", "www.example.com", "127.0.0.1"]+    ]+  , [ itemProcess .~ p $ theItem+          | p <- [0, 1, 1337, 2147483647]+    ]+  , [ itemMessage .~ LogStr m $ theItem+          | m <- [ "message"+                 , "message\nwith newline"+                 , LT.fromLazyText (LT.replicate 40 " a really long message")+                 , "сообщение"+                 , "哈囉世界"+                 ]+    ]+  , [ itemTime .~ t $ theItem+          | t <- genDates+    ]+  , [ itemNamespace .~ Namespace ns $ theItem+          | ns <- [ ["foo"]+                  , ["foo", "bar"]+                  , ["фу", "бар"]+                  , ["with\nnewline"] ]+    ]+  , [ itemLoc .~ l $ theItem | l <- genLocs+    ]+  ]++genDates :: [UTCTime]+genDates =+  [ mkUTCTime 2000 1   1 0   0  0.0+  , mkUTCTime 2123 12 31 23  59 59.999999999999+  , mkUTCTime 2016 10 10 1   1  5.0+  , mkUTCTime 2100 12 31 12  59 10.1+  , mkUTCTime 1982 1  1  12  30 0.000000000001+  ]++genLocs :: [Maybe Loc]+genLocs =+  [ Nothing+  , Just $ Loc "path/Some/Module.hs"+               "main"+               "Some.Module"+               (30,1) (30,14)+  , Just $ Loc "путь/Some/Module.hs"+               "main"+               "Some.Module"+               (3000,9000) (4000,1)+  ]++genTypedItems :: [Item AllTypesLogItem]+genTypedItems =+  [ itemPayload .~ p $ theItem+        | p <- [ AllTypesLogItem "" 0 0.0 [] Nothing+               , AllTypesLogItem "note" 10 5.5 ["one", "two", "three"]+                     (Just dummyLogItem)+               ]+  ]++mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime+mkUTCTime y mt d h mn s = UTCTime day dt+  where+    day = fromGregorian y mt d+    dt = h * 60 * 60 + mn * 60 + s++-------------------------------------------------------------------------------+writeTextLog :: (FilePath, Handle) -> IO (BL.ByteString)+writeTextLog (path, h) = do+    mapM_ (T.hPutStrLn h . formatOne) genItems+    mapM_ (T.hPutStrLn h . formatOne) genTypedItems+    hClose h+    BL.readFile path+  where+    formatOne :: LogItem a => Item a -> Text+    formatOne = LT.toStrict . LT.toLazyText . formatItem False V3++setupTempFile :: IO (FilePath, Handle)+setupTempFile = do+    tempDir <- getTemporaryDirectory+    (fp, h) <- openBinaryTempFile tempDir "katip.log"+    return (fp, h)++teardownTempFile :: (FilePath, Handle) -> IO ()+teardownTempFile (_, h) = do+    chk <- hIsOpen h+    when chk $ hClose h

@@ -4,6 +4,7 @@ import           Test.Tasty ------------------------------------------------------------------------------- import qualified Katip.Tests+import qualified Katip.Tests.Format.Time import qualified Katip.Tests.Scribes.Handle ------------------------------------------------------------------------------- @@ -15,5 +16,6 @@ testSuite = testGroup "katip"   [     Katip.Tests.tests+  , Katip.Tests.Format.Time.tests   , Katip.Tests.Scribes.Handle.tests   ]