diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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`. diff --git a/katip.cabal b/katip.cabal --- a/katip.cabal +++ b/katip.cabal @@ -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 diff --git a/src/Katip/Format/Time.hs b/src/Katip/Format/Time.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Format/Time.hs @@ -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 diff --git a/src/Katip/Monadic.hs b/src/Katip/Monadic.hs --- a/src/Katip/Monadic.hs +++ b/src/Katip/Monadic.hs @@ -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 diff --git a/src/Katip/Scribes/Handle.hs b/src/Katip/Scribes/Handle.hs --- a/src/Katip/Scribes/Handle.hs +++ b/src/Katip/Scribes/Handle.hs @@ -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 diff --git a/test/Katip/Tests/Scribes/Handle.hs b/test/Katip/Tests/Scribes/Handle.hs --- a/test/Katip/Tests/Scribes/Handle.hs +++ b/test/Katip/Tests/Scribes/Handle.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ]