packages feed

df1 (empty) → 0.1

raw patch · 10 files changed

+1022/−0 lines, 10 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bytestring, containers, df1, tasty, tasty-quickcheck, text, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Version 0.1++Consider this a preview release: The API is likely to stay stable, but extensive+testing, formalization and tooling is due.
+ LICENSE.txt view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Renzo Carbonara++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Renzo Carbonara nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,14 @@+# df1++Hierarchical structured logging format. Easy for humans, fast for computers.++This library provides types, parsers and renderers for `df1`.++Consider this a preview release: The API is likely to stay stable, but extensive+testing, formalization and tooling is due.++[![Build Status](https://travis-ci.org/k0001/di.svg?branch=master)](https://travis-ci.org/k0001/di)++See the [BSD3 LICENSE](https://github.com/k0001/di/blob/master/df1/LICENSE.txt)+file to learn about the legal terms and conditions for this library.+
+ Setup.hs view
@@ -0,0 +1,4 @@+#! /usr/bin/env nix-shell+#! nix-shell ./shell.nix -i runghc+import Distribution.Simple+main = defaultMain
+ df1.cabal view
@@ -0,0 +1,48 @@+name: df1+version: 0.1+author: Renzo Carbonara+maintainer: renλren.zone+copyright: Renzo Carbonara 2018+license: BSD3+license-file: LICENSE.txt+extra-source-files: README.md CHANGELOG.md+category: Logging+build-type: Simple+cabal-version: >=1.18+synopsis: Type, render and parse the df1 hierarchical structured log format+description:+  Type, render and parse logs in /df1/ format, a hierarchical structured+  log format that is easy for humans and fast for computers.+homepage: https://github.com/k0001/di+bug-reports: https://github.com/k0001/di/issues++library+  hs-source-dirs: lib+  default-language: Haskell2010+  exposed-modules: Df1+  other-modules: Df1.Render Df1.Parse Df1.Types+  build-depends:+    attoparsec,+    base >=4.9 && <5.0,+    bytestring,+    containers,+    text,+    time+  ghcjs-options: -Wall -O3+  ghc-options: -Wall -O2++test-suite test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    attoparsec,+    base,+    bytestring,+    df1,+    QuickCheck,+    text,+    time,+    tasty,+    tasty-quickcheck
+ lib/Df1.hs view
@@ -0,0 +1,25 @@+-- | This module exports tools for typing, parsing, and rendering logs in the+-- /df1/ hierarchical structured logging format.+--+-- Consider this a preview release: The API is likely to stay stable, but+-- extensive testing, formalization and tooling is due.+module Df1+ ( -- * Types+   T.Log(Log, log_time, log_level, log_path, log_message)+ , T.Level(Debug, Info, Notice, Warning, Error, Critical, Alert, Emergency)+ , T.Path(Attr, Push)+ , T.Segment, T.unSegment, T.segment+ , T.Key, T.unKey, T.key+ , T.Value, T.unValue, T.value+ , T.Message, T.unMessage, T.message+   -- * Parsing+ , P.parse+   -- * Rendering+ , R.render+ , R.renderColor+ ) where++import qualified Df1.Parse as P+import qualified Df1.Render as R+import qualified Df1.Types as T+
+ lib/Df1/Parse.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Df1.Parse+ ( parse+ ) where++import Control.Applicative ((<|>), many, empty)+import Data.Bits (shiftL)+import qualified Data.Sequence as Seq+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Function (fix)+import Data.Functor (($>))+import qualified Data.Attoparsec.ByteString as AB+import qualified Data.Attoparsec.ByteString.Lazy as ABL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Time as Time+import qualified Data.Time.Clock.System as Time+import Data.Word (Word8, Word16, Word32)++import Df1.Types+ (Log(Log, log_time, log_level, log_path, log_message),+  Level(Debug, Info, Notice, Warning, Error, Critical, Alert, Emergency),+  Path(Attr, Push),+  Segment, segment,+  Key, key,+  Value, value,+  Message, message)++--------------------------------------------------------------------------------++-- | If sucessful, parsing will stop after the first CR or LF newline marker if+-- any, otherwise it will consume all input.+parse :: AB.Parser Log+{-# INLINABLE parse #-}+parse = (AB.<?> "parse") $ do+  t <- AB.skipWhile (== 32) *> pIso8601+  p <- AB.skipWhile (== 32) *> pPath+  l <- AB.skipWhile (== 32) *> pLevel+  m <- AB.skipWhile (== 32) *> pMessage+  pure (Log { log_time = Time.utcToSystemTime t+            , log_level = l, log_path = p, log_message = m })++pIso8601 :: AB.Parser Time.UTCTime+{-# INLINABLE pIso8601 #-}+pIso8601 = (AB.<?> "pIso8601") $ do+  year <- (pNum4Digits AB.<?> "year") <* (AB.skip (== 45) AB.<?> "-")+  month <- (pNum2Digits AB.<?> "month") <* (AB.skip (== 45) AB.<?> "-")+  day <- (pNum2Digits AB.<?> "day") <* (AB.skip (== 84) AB.<?> "T")+  Just tday <- pure (Time.fromGregorianValid+     (fromIntegral year) (fromIntegral month) (fromIntegral day))+  hour <- (pNum2Digits AB.<?> "hour") <* (AB.skip (== 58) AB.<?> ":")+  min' <- (pNum2Digits AB.<?> "minute") <* (AB.skip (== 58) AB.<?> ":")+  sec <- (pNum2Digits AB.<?> "second") <* (AB.skip (== 46) AB.<?> ".")+  nsec <- (pNum9Digits AB.<?> "nanosecond") <* (AB.skip (== 90) AB.<?> "Z")+  Just ttod <- pure (Time.makeTimeOfDayValid+     (fromIntegral hour) (fromIntegral min')+     (fromIntegral sec + (fromIntegral nsec / 1000000000)))+  pure (Time.UTCTime tday (Time.timeOfDayToTime ttod))++pNum1Digit :: AB.Parser Word8+{-# INLINE pNum1Digit #-}+pNum1Digit = AB.satisfyWith (subtract 48) (< 10) AB.<?> "pNum1Digit"++pNum2Digits :: AB.Parser Word8+{-# INLINE pNum2Digits #-}+pNum2Digits = (AB.<?> "pNum2Digits") $ do+  (+) <$> fmap (* 10) pNum1Digit <*> pNum1Digit++pNum4Digits :: AB.Parser Word16+{-# INLINE pNum4Digits #-}+pNum4Digits = (AB.<?> "pNum4Digits") $ do+  (\a b c d -> a + b + c + d)+     <$> fmap ((* 1000) . fromIntegral) pNum1Digit+     <*> fmap ((* 100) . fromIntegral) pNum1Digit+     <*> fmap ((* 10) . fromIntegral) pNum1Digit+          <*> fmap fromIntegral pNum1Digit++pNum9Digits :: AB.Parser Word32+{-# INLINE pNum9Digits #-}+pNum9Digits = (AB.<?> "pNum9Digits") $ do+  (\a b c d e f g h i -> a + b + c + d + e + f + g + h + i)+     <$> fmap ((* 100000000) . fromIntegral) pNum1Digit+     <*> fmap ((* 10000000) . fromIntegral) pNum1Digit+     <*> fmap ((* 1000000) . fromIntegral) pNum1Digit+     <*> fmap ((* 100000) . fromIntegral) pNum1Digit+     <*> fmap ((* 10000) . fromIntegral) pNum1Digit+     <*> fmap ((* 1000) . fromIntegral) pNum1Digit+     <*> fmap ((* 100) . fromIntegral) pNum1Digit+     <*> fmap ((* 10) . fromIntegral) pNum1Digit+     <*> fmap fromIntegral pNum1Digit++pLevel :: AB.Parser Level+{-# INLINE pLevel #-}+pLevel = (AB.<?> "pLevel")+  -- In decreasing frequency we expect logs to happen.+  -- We expect 'Debug' to mostly be muted, so 'Info' is prefered.+  (AB.string "INFO"      $> Info)     <|>+  (AB.string "DEBUG"     $> Debug)    <|>+  (AB.string "NOTICE"    $> Notice)   <|>+  (AB.string "WARNING"   $> Warning)  <|>+  (AB.string "ERROR"     $> Error)    <|>+  (AB.string "CRITICAL"  $> Critical) <|>+  (AB.string "ALERT"     $> Alert)    <|>+  (AB.string "EMERGENCY" $> Emergency)++pPath :: AB.Parser (Seq.Seq Path)+{-# INLINABLE pPath #-}+pPath = (AB.<?> "pPath") $ do+    fix (\k ps -> ((pPush <|> pAttr) >>= \p -> k (ps Seq.|> p)) <|> pure ps)+        mempty+  where+    {-# INLINE pPush #-}+    pPush :: AB.Parser Path+    pPush = (AB.<?> "pPush") $ do+      seg <- pSegment <* AB.skipWhile (== 32)+      pure (Push seg)+    {-# INLINE pAttr #-}+    pAttr :: AB.Parser Path+    pAttr = do+      k <- pKey <* AB.skip (== 61)+      v <- pValue <* AB.skipWhile (== 32)+      pure (Attr k v)++pSegment :: AB.Parser Segment+pSegment = (AB.<?> "pSegment") $ do+  AB.skip (== 47) AB.<?> "/"+  bl <- pUtf8LtoL =<< pDecodePercents =<< AB.takeWhile (/= 32) -- :space:+  pure (segment (TL.toStrict bl))++pKey :: AB.Parser Key+pKey = (AB.<?> "pKey") $ do++  bl <- pUtf8LtoL =<< pDecodePercents+          =<< AB.takeWhile (\w -> w /= 61 && w /= 32) -- '=' or :space:+  pure (key (TL.toStrict bl))++pValue :: AB.Parser Value+pValue = (AB.<?> "pValue") $ do+  bl <- pUtf8LtoL =<< pDecodePercents =<< AB.takeWhile (/= 32) -- :space:+  pure (value bl)++pMessage :: AB.Parser Message+{-# INLINE pMessage #-}+pMessage = (AB.<?> "pMessage") $ do+  b <- AB.takeWhile (\w -> w /= 10 && w /= 13) -- CR and LF+  tl <- pUtf8LtoL =<< pDecodePercents b+  pure (message tl)++pUtf8LtoL :: BL.ByteString -> AB.Parser TL.Text+{-# INLINE pUtf8LtoL #-}+pUtf8LtoL = \bl -> case TL.decodeUtf8' bl of+   Right x -> pure x+   Left e -> fail (show e) AB.<?> "pUtf8LtoL"++-- | Parse @\"%FF\"@. Always consumes 3 bytes from the input, if successful.+pNumPercent :: AB.Parser Word8+{-# INLINE pNumPercent #-}+pNumPercent = (AB.<?> "pNum2Nibbles") $ do+   AB.skip (== 37) -- percent+   wh <- pHexDigit+   wl <- pHexDigit+   pure (shiftL wh 4 + wl)++pHexDigit :: AB.Parser Word8+{-# INLINE pHexDigit #-}+pHexDigit = AB.satisfyWith+  (\case w | w >= 48 && w <=  57 -> w - 48+           | w >= 65 && w <=  70 -> w - 55+           | w >= 97 && w <= 102 -> w - 87+           | otherwise -> 99)+  (\w -> w /= 99)++-- | Like 'pDecodePercentsL' but takes strict bytes.+pDecodePercents :: B.ByteString -> AB.Parser BL.ByteString+{-# INLINE pDecodePercents #-}+pDecodePercents = pDecodePercentsL . BL.fromStrict++-- | Decodes all 'pNumPercent' occurences from the given input.+--+-- TODO: Make faster and more space efficient.+pDecodePercentsL :: BL.ByteString -> AB.Parser BL.ByteString+{-# INLINABLE pDecodePercentsL #-}+pDecodePercentsL = \bl ->+    either fail pure (ABL.eitherResult (ABL.parse p bl))+  where+    p :: AB.Parser BL.ByteString+    p = AB.atEnd >>= \case+          True -> pure mempty+          False -> fix $ \k -> do+             b <- AB.peekWord8 >>= \case+                Nothing -> empty+                Just 37 -> fmap B.singleton pNumPercent+                Just _  -> AB.takeWhile1 (\w -> w /= 37)+             bls <- many k <* AB.endOfInput+             pure (mconcat (BL.fromStrict b : bls))+
+ lib/Df1/Render.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Df1.Render+ ( render+ , renderColor+ ) where++import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Prim as BBP+import Data.Function (fix)+import Data.Monoid ((<>))+import qualified Data.Sequence as Seq+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Time as Time+import qualified Data.Time.Clock.System as Time+import Data.Word (Word8, Word32)+import Prelude hiding (log, filter, error)++import Df1.Types+ (Log(log_time, log_level, log_path, log_message),+  Level(Debug, Info, Notice, Warning, Error, Critical, Alert, Emergency),+  Path(Attr, Push),+  Segment, unSegment,+  Key, unKey,+  Value, unValue,+  Message, unMessage)++--------------------------------------------------------------------------------++-- This is rather ugly, but whatever.+renderColor :: Log -> BB.Builder+{-# INLINABLE renderColor #-}+renderColor = \log_ ->+ let t = renderIso8601 (log_time log_) <> space+     pDef = \fg -> renderPathColor fg fgBlue fgCyan (log_path log_)+     pRed = renderPathColor fgBlack fgWhite fgWhite (log_path log_)+     m = space <> renderMessage (log_message log_) <> reset+ in case log_level log_ of+     Debug -> reset <> t <> pDef fgDefault <> fgDefault <> debug <> m+     Info -> reset <> t <> pDef fgDefault <> fgDefault <> info <> m+     Notice ->+       bgDefault <> fgGreen <> t <> pDef fgDefault <> fgGreen <> notice <> m+     Warning ->+       bgDefault <> fgYellow <> t <> pDef fgDefault <> fgYellow <> warning <> m+     Error ->+       bgDefault <> fgRed <> t <> pDef fgDefault <> fgRed <> error <> m+     Critical ->+       bgRed <> fgBlack <> t <> pRed <> fgWhite <> critical <> fgBlack <> m+     Alert ->+       bgRed <> fgBlack <> t <> pRed <> fgWhite <> alert <> fgBlack <> m+     Emergency ->+       bgRed <> fgBlack <> t <> pRed <> fgWhite <> emergency <> fgBlack <> m++-- | Like 'renderColor', but without color.+render :: Log -> BB.Builder+{-# INLINABLE render #-}+render = \x ->+  renderIso8601 (log_time x) <> space <>+  renderPath (log_path x) <>+  level (log_level x) <> space <>+  renderMessage (log_message x)++-- | @'renderPathColor' a b c p@ renders @p@ using @a@ as the default color (for+-- things like whitespace or attribute values), @b@ as the color for path names,+-- and @c@ as the color for attribute keys. This adds a trailing whitespace if+-- necessary.+renderPathColor+  :: BB.Builder -> BB.Builder -> BB.Builder -> Seq.Seq Path -> BB.Builder+{-# INLINE renderPathColor #-}+renderPathColor defc pathc keyc = fix $ \f -> \case+  ps Seq.:|> Attr k v ->+    f ps <> defc <> keyc <> renderKey k <>+    defc <> equals <> renderValue v <> space+  ps Seq.:|> Push s -> f ps <> defc <> pathc <> slash <> renderSegment s <> space+  Seq.Empty -> mempty++-- | Like 'renderPathColor', but without color.+renderPath :: Seq.Seq Path -> BB.Builder+{-# INLINE renderPath #-}+renderPath = fix $ \f -> \case+  ps Seq.:|> Attr k v -> f ps <> renderKey k <> equals <> renderValue v <> space+  ps Seq.:|> Push s -> f ps <> slash <> renderSegment s <> space+  Seq.Empty -> mempty++renderMessage :: Message -> BB.Builder+{-# INLINE renderMessage #-}+renderMessage = escapeMessage . unMessage++escapeMessage :: TL.Text -> BB.Builder+{-# INLINE escapeMessage #-}+escapeMessage = TL.encodeUtf8BuilderEscaped+  $ BBP.condB (== 37) word8HexPercent  -- '%'+  $ BBP.condB (<= 31) word8HexPercent  -- control characters+  $ BBP.liftFixedToBounded BBP.word8++renderSegment :: Segment -> BB.Builder+{-# INLINE renderSegment #-}+renderSegment = escapeMetaL . TL.fromStrict . unSegment++renderKey :: Key -> BB.Builder+{-# INLINE renderKey #-}+renderKey = escapeMetaL . TL.fromStrict . unKey++renderValue :: Value -> BB.Builder+{-# INLINE renderValue #-}+renderValue = escapeMetaL . unValue++-- | Escape metadata such as path segments, attribute keys or attribute values.+escapeMetaL :: TL.Text -> BB.Builder+{-# INLINE escapeMetaL #-}+escapeMetaL = TL.encodeUtf8BuilderEscaped+   $ BBP.condB+        (\w -> (w <= 47)               -- Control and separator-like+            || (w >= 58 && w <= 64)    -- Delimiter-like+            || (w >= 91 && w <= 96)    -- Delimiter-like+            || (w >= 123 && w <= 127)) -- Delimiter-like and DEL+        word8HexPercent+   $ BBP.liftFixedToBounded BBP.word8++--------------------------------------------------------------------------------+-- Some hardcoded stuff we use time and time again++debug :: BB.Builder+debug = BB.string7 "DEBUG"+{-# INLINE debug #-}++info :: BB.Builder+info = BB.string7 "INFO"+{-# INLINE info #-}++notice :: BB.Builder+notice = BB.string7 "NOTICE"+{-# INLINE notice #-}++warning :: BB.Builder+warning = BB.string7 "WARNING"+{-# INLINE warning #-}++error :: BB.Builder+error = BB.string7 "ERROR"+{-# INLINE error #-}++critical :: BB.Builder+critical = BB.string7 "CRITICAL"+{-# INLINE critical #-}++alert :: BB.Builder+alert = BB.string7 "ALERT"+{-# INLINE alert #-}++emergency :: BB.Builder+emergency = BB.string7 "EMERGENCY"+{-# INLINE emergency #-}++level :: Level -> BB.Builder+{-# INLINE level #-}+level = \case+  { Debug -> debug; Info -> info;+    Notice -> notice; Warning -> warning;+    Error -> error; Critical -> critical;+    Alert -> alert; Emergency -> emergency }++space :: BB.Builder+space = BB.char7 ' '+{-# INLINE space #-}++slash :: BB.Builder+slash = BB.char7 '/'+{-# INLINE slash #-}++equals :: BB.Builder+equals = BB.char7 '='+{-# INLINE equals #-}++--------------------------------------------------------------------------------+-- ANSI escape codes++-- | Reset all+reset :: BB.Builder+reset = BB.string7 "\x1b[0m"+{-# INLINE reset #-}++-- | Default foreground+fgDefault :: BB.Builder+fgDefault = BB.string7 "\x1b[39m"+{-# INLINE fgDefault #-}++-- | Reset background+bgDefault :: BB.Builder+bgDefault = BB.string7 "\x1b[49m"+{-# INLINE bgDefault #-}++-- | green foreground+fgGreen :: BB.Builder+fgGreen = BB.string7 "\x1b[32m"+{-# INLINE fgGreen #-}++-- | green foreground+fgRed :: BB.Builder+fgRed = BB.string7 "\x1b[31m"+{-# INLINE fgRed #-}++-- | Yellow foreground+fgYellow :: BB.Builder+fgYellow = BB.string7 "\x1b[33m"+{-# INLINE fgYellow #-}++-- | Cyan foreground+fgCyan :: BB.Builder+fgCyan = BB.string7 "\x1b[36m"+{-# INLINE fgCyan #-}++-- | Blue foreground+fgBlue :: BB.Builder+fgBlue = BB.string7 "\x1b[34m"+{-# INLINE fgBlue #-}++-- | Black foreground+fgBlack :: BB.Builder+fgBlack = BB.string7 "\x1b[30m"+{-# INLINE fgBlack #-}++-- | White foreground+fgWhite :: BB.Builder+fgWhite = BB.string7 "\x1b[37m"+{-# INLINE fgWhite #-}++-- | Red background+bgRed :: BB.Builder+bgRed = BB.string7 "\x1b[41m"+{-# INLINE bgRed #-}++-- | Render @'%'@ followed by the given 'Word8' rendered as two hexadecimal+-- nibbles.+word8HexPercent :: BBP.BoundedPrim Word8+word8HexPercent = BBP.liftFixedToBounded+  ((\x -> (37, x)) BBP.>$< BBP.word8 BBP.>*< BBP.word8HexFixed)+{-# INLINE word8HexPercent #-}++--------------------------------------------------------------------------------++-- | Renders /YYYY-MM-DDThh:mm:ss.sssssssssZ/ (nanosecond precision).+--+-- The rendered string is a 30 characters long, and it's ASCII-encoded.+renderIso8601 :: Time.SystemTime -> BB.Builder+{-# INLINE renderIso8601 #-}+renderIso8601 = \syst ->+  let Time.UTCTime tday tdaytime = Time.systemToUTCTime syst+      (year, month, day) = Time.toGregorian tday+      Time.TimeOfDay hour min' sec = Time.timeToTimeOfDay tdaytime+  in -- Notice that 'TB.decimal' RULES dispatch to faster code for smaller+     -- types (e.g., 'Word8' is faster to render than 'Int'), so we make+     -- seemingly redundant 'fromIntegral' conversions here to that effect.+     BB.int16Dec (fromIntegral year) <> BB.char7 '-' <>+     word8Dec_pad10 (fromIntegral month) <> BB.char7 '-' <>+     word8Dec_pad10 (fromIntegral day) <> BB.char7 'T' <>+     word8Dec_pad10 (fromIntegral hour) <> BB.char7 ':' <>+     word8Dec_pad10 (fromIntegral min') <> BB.char7 ':' <>+     word8Dec_pad10 (truncate sec) <> BB.char7 '.' <>+     word32Dec_pad100000000 (Time.systemNanoseconds syst) <> BB.char7 'Z'++word8Dec_pad10 :: Word8 -> BB.Builder+{-# INLINE word8Dec_pad10 #-}+word8Dec_pad10 x =+  let !y = BB.word8Dec x+  in if x < 10 then (_zero1 <> y) else y++word32Dec_pad100000000 :: Word32 -> BB.Builder+{-# INLINE word32Dec_pad100000000 #-}+word32Dec_pad100000000 x =+  let !y = BB.word32Dec x+  in if | x < 10 -> _zero8 <> y+        | x < 100 -> _zero7 <> y+        | x < 1000 -> _zero6 <> y+        | x < 10000 -> _zero5 <> y+        | x < 100000 -> _zero4 <> y+        | x < 1000000 -> _zero3 <> y+        | x < 10000000 -> _zero2 <> y+        | x < 100000000 -> _zero1 <> y+        | otherwise -> y++_zero1, _zero2, _zero3, _zero4, _zero5, _zero6, _zero7, _zero8 :: BB.Builder+_zero1 = BB.string7 "0"+_zero2 = BB.string7 "00"+_zero3 = BB.string7 "000"+_zero4 = BB.string7 "0000"+_zero5 = BB.string7 "00000"+_zero6 = BB.string7 "000000"+_zero7 = BB.string7 "0000000"+_zero8 = BB.string7 "00000000"+{-# INLINE _zero1 #-}+{-# INLINE _zero2 #-}+{-# INLINE _zero3 #-}+{-# INLINE _zero4 #-}+{-# INLINE _zero5 #-}+{-# INLINE _zero6 #-}+{-# INLINE _zero7 #-}+{-# INLINE _zero8 #-}
+ lib/Df1/Types.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE StandaloneDeriving #-}++module Df1.Types+ ( Log(Log, log_time, log_level, log_path, log_message)+ , Level(Debug, Info, Notice, Warning, Error, Critical, Alert, Emergency)+ , Path(Attr, Push)+ , Segment, unSegment, segment+ , Key, unKey, key+ , Value, unValue, value+ , Message, unMessage, message+ ) where++import Data.Semigroup (Semigroup)+import Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.String (IsString(fromString))+import qualified Data.Time.Clock.System as Time++--------------------------------------------------------------------------------++data Log = Log+  { log_time :: !Time.SystemTime+    -- ^ First known timestamp when the log was generated.+    --+    -- We use 'Time.SystemTime' rather than 'Time.UTCTime' because it is+    -- cheaper to obtain and to render. You can use+    -- 'Data.Time.Clock.System.systemToUTCTime' to convert it if necessary.+  , log_level :: !Level+    -- ^ Importance level of the logged message.+  , log_path :: !(Seq.Seq Path)+    -- ^ 'Path' where the logged message was created from.+    --+    -- The leftmost 'Path' is the closest to the root. The rightmost 'Path' is+    -- the one closest to where the log was generated.+    --+    -- An 'Seq.empty' 'Seq.Seq' is acceptable, conveying the idea of the “root+    -- path”.+  , log_message :: !Message+    -- ^ Human-readable message itself.+  } deriving (Eq, Show)++--------------------------------------------------------------------------------++-- | A message text.+--+-- If you have the @OverloadedStrings@ GHC extension enabled, you can build a+-- 'Message' using a string literal:+--+-- @+-- \"foo\" :: 'Message'+-- @+--+-- Please keep in mind that 'Message' will always strip surrounding whitespace.+-- That is:+--+-- @+-- \"x\" :: 'Message'  ==  \" x\"  == \"x \" == \" x \"+-- @+newtype Message = Message TL.Text+  deriving (Eq, Show)++message :: TL.Text -> Message+message = Message . TL.dropAround (== ' ')+{-# INLINE message #-}++unMessage :: Message -> TL.Text+unMessage = \(Message x) -> x+{-# INLINE unMessage #-}++instance IsString Message where+  fromString = message . TL.pack+  {-# INLINE fromString #-}++instance Semigroup Message where+  (<>) (Message a) (Message b) = Message (a <> b)+  {-# INLINE (<>) #-}++instance Monoid Message where+  mempty = Message mempty+  {-# INLINE mempty #-}+  mappend (Message a) (Message b) = Message (mappend a b)+  {-# INLINE mappend #-}++--------------------------------------------------------------------------------++-- | Importance of the logged message.+--+-- These levels, listed in increasing order of importance, correspond to the+-- levels used by [syslog(3)](https://linux.die.net/man/3/syslog).+data Level+  = Debug+  -- ^ Message intended to be useful only when deliberately debugging a program.+  | Info+  -- ^ Informational message.+  | Notice+  -- ^ A condition that is not an error, but should possibly be handled+  -- specially.+  | Warning+  -- ^ A warning condition, such as an exception being gracefully handled or+  -- some missing configuration setting being assigned a default value.+  | Error+  -- ^ Error condition, such as an unhandled exception.+  | Critical+  -- ^ Critical condition that could result in system failure, such as a disk+  -- running out of space.+  | Alert+  -- ^ A condition that should be corrected immediately, such as a corrupted+  -- database.+  | Emergency+  -- ^ System is unusable.+  deriving (Eq, Show, Bounded, Enum)++-- | Order of importance. For example, 'Emergency' is more important than+-- 'Debug':+--+-- @+-- 'Emergency' > 'Debug'  ==  'True'+-- @+deriving instance Ord Level++--------------------------------------------------------------------------------++-- | A path segment.+--+-- If you have the @OverloadedStrings@ GHC extension enabled, you can build a+-- 'Segment' using a string literal:+--+-- @+-- \"foo\" :: 'Segment'+-- @+--+-- Otherwise, you can use 'fromString' or the 'Segment' constructor directly.+newtype Segment = Segment T.Text+  deriving (Eq, Show)++segment :: T.Text -> Segment+segment = Segment . T.dropAround (== ' ')+{-# INLINE segment #-}++unSegment :: Segment -> T.Text+unSegment = \(Segment x) -> x+{-# INLINE unSegment #-}++instance IsString Segment where+  fromString = segment . T.pack+  {-# INLINE fromString #-}++instance Semigroup Segment where+  (<>) (Segment a) (Segment b) = Segment (a <> b)+  {-# INLINE (<>) #-}++instance Monoid Segment where+  mempty = Segment mempty+  {-# INLINE mempty #-}+  mappend (Segment a) (Segment b) = Segment (mappend a b)+  {-# INLINE mappend #-}++--------------------------------------------------------------------------------++-- | An attribute key (see 'Attr').+--+-- If you have the @OverloadedStrings@ GHC extension enabled, you can build a+-- 'Key' using a string literal:+--+-- @+-- \"foo\" :: 'Key'+-- @+--+-- Otherwise, you can use 'fromString' or the 'key' function.+--+-- Please keep in mind that 'Key' will always strip surrounding whitespace.+-- That is:+--+-- @+-- \"x\" :: 'Key'  ==  \" x\"  == \"x \" == \" x \"+-- @+newtype Key = Key T.Text+  deriving (Eq, Show)++key :: T.Text -> Key+key = Key . T.dropAround (== ' ')+{-# INLINE key #-}++unKey :: Key -> T.Text+unKey = \(Key x) -> x+{-# INLINE unKey #-}++instance IsString Key where+  fromString = key . T.pack+  {-# INLINE fromString #-}++instance Semigroup Key where+  (<>) (Key a) (Key b) = Key (a <> b)+  {-# INLINE (<>) #-}++instance Monoid Key where+  mempty = Key mempty+  {-# INLINE mempty #-}+  mappend (Key a) (Key b) = Key (mappend a b)+  {-# INLINE mappend #-}++--------------------------------------------------------------------------------++-- | An attribute value (see 'Attr').+--+-- If you have the @OverloadedStrings@ GHC extension enabled, you can build a+-- 'Value' using a string literal:+--+-- @+-- \"foo\" :: 'Value'+-- @+--+-- Otherwise, you can use 'fromString' or the 'value' function.+--+-- Please keep in mind that 'value' will always strip surrounding whitespace.+-- That is:+--+-- @+-- \"x\" :: 'Value'  ==  \" x\"  == \"x \" == \" x \"+-- @+newtype Value = Value TL.Text+  deriving (Eq, Show)++unValue :: Value -> TL.Text+unValue = \(Value x) -> x+{-# INLINE unValue #-}++value :: TL.Text -> Value+value = Value . TL.dropAround (== ' ')+{-# INLINE value #-}++instance IsString Value where+  fromString = value . TL.pack+  {-# INLINE fromString #-}++instance Semigroup Value where+  (<>) (Value a) (Value b) = Value (a <> b)+  {-# INLINE (<>) #-}++instance Monoid Value where+  mempty = Value mempty+  {-# INLINE mempty #-}+  mappend (Value a) (Value b) = Value (mappend a b)+  {-# INLINE mappend #-}++--------------------------------------------------------------------------------++-- | 'Path' represents the hierarchical structure of logged messages.+--+-- For example, consider a /df1/ log line as like the following:+--+-- @+-- 1999-12-20T07:11:39.230553031Z /foo x=a y=b /qux z=c z=d WARNING Something+-- @+--+-- For that line, the 'log_path' attribute of the 'Log' datatype will contain+-- the following:+--+-- @+-- [ 'Push' ('segment' \"foo\")+-- , 'Attr' ('key' \"x\") ('value' \"a\")+-- , 'Attr' ('key' \"y\") ('value' \"b\")+-- , 'Push' ('segment' \"qux\")+-- , 'Attr' ('key' \"z\") ('value' \"c\")+-- , 'Attr' ('key' \"z\") ('value' \"d\")+-- ] :: 'Seq.Seq' 'Path'+-- @+--+-- Please notice that @[] :: 'Seq.Seq' 'Path'@ is a valid path insofar as /df1/+-- is concerned, and that 'Attr' and 'Push' can be juxtapositioned in any order.+data Path+  = Push !Segment+  | Attr !Key !Value+  deriving (Eq, Show)+
+ test/Main.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative ((<|>), many)+import Data.Attoparsec.ByteString.Lazy as ABL+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Builder as BB+import Data.Functor (($>))+import Data.String (fromString)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time.Clock.System as Time+import qualified Test.Tasty as Tasty+import Test.Tasty.QuickCheck ((===))+import qualified Test.Tasty.QuickCheck as QC+import qualified Test.Tasty.Runners as Tasty++import qualified Df1++--------------------------------------------------------------------------------++main :: IO ()+main = Tasty.defaultMainWithIngredients+  [ Tasty.consoleTestReporter+  , Tasty.listingTests+  ] tt++tt :: Tasty.TestTree+tt = Tasty.testGroup "df1"+  [ Tasty.localOption (QC.QuickCheckTests 1000) $+    QC.testProperty "Render/Parse roundtrip" $ do+      QC.forAllShrink QC.arbitrary QC.shrink $ \log0 -> do+         let bl = BB.toLazyByteString (Df1.render log0)+         Right log0 === ABL.eitherResult (ABL.parse Df1.parse bl)++  , Tasty.localOption (QC.QuickCheckTests 1000) $+    QC.testProperty "Color renders the same content" $ do+      QC.forAllShrink QC.arbitrary QC.shrink $ \log0 -> do+         let bl = BB.toLazyByteString (Df1.render log0)+             blColor = BB.toLazyByteString (Df1.renderColor log0)+         bl === removeAnsiEscapes blColor+  ]++instance QC.Arbitrary Df1.Log where+  arbitrary = Df1.Log+    <$> genSystemTime <*> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary+  shrink (Df1.Log a b c d) = Df1.Log+    <$> pure a <*> QC.shrink b <*> QC.shrink c <*> QC.shrink d++instance QC.Arbitrary Df1.Path where+  arbitrary = QC.oneof+    [ Df1.Push <$> QC.arbitrary+    , Df1.Attr <$> QC.arbitrary <*> QC.arbitrary ]+  shrink (Df1.Push s) = Df1.Push <$> QC.shrink s+  shrink (Df1.Attr k v) = Df1.Attr <$> QC.shrink k <*> QC.shrink v++instance QC.Arbitrary Df1.Level where+  arbitrary = QC.elements [minBound .. minBound]++instance QC.Arbitrary Df1.Segment where+  arbitrary = fromString <$> QC.arbitrary+  shrink = map Df1.segment . QC.shrink . Df1.unSegment++instance QC.Arbitrary Df1.Key where+  arbitrary = fromString <$> QC.arbitrary+  shrink = map Df1.key . QC.shrink . Df1.unKey++instance QC.Arbitrary Df1.Value where+  arbitrary = fromString <$> QC.arbitrary+  shrink = map Df1.value . QC.shrink . Df1.unValue++instance QC.Arbitrary Df1.Message where+  arbitrary = fromString <$> QC.arbitrary+  shrink = map Df1.message . QC.shrink . Df1.unMessage++instance QC.Arbitrary T.Text where+  arbitrary = T.pack <$> QC.arbitrary+  shrink = map T.pack . QC.shrink . T.unpack++instance QC.Arbitrary TL.Text where+  arbitrary = TL.pack <$> QC.arbitrary+  shrink = map TL.pack . QC.shrink . TL.unpack++genSystemTime :: QC.Gen Time.SystemTime+genSystemTime = do+  a <- QC.choose (0, 253402300799) -- up to 4 digit years+  b <- QC.choose (0, 1000000000)+  pure (Time.MkSystemTime a b)++--------------------------------------------------------------------------------++-- | Remove ANSI escapes. This is not complete, but it covers the ANSI codes we+-- use. In particular:+--+-- @+-- forall x.+--    'BB.toByteString' . 'render'+--        == 'removeAnsiEscapes' . 'BB.toByteString' . 'renderColor'+-- @+removeAnsiEscapes :: BL.ByteString -> BL.ByteString+removeAnsiEscapes b0 = do+    case ABL.eitherResult (ABL.parse p b0) of+       Right b1 -> b1+       Left e -> Prelude.error ("removeAnsiEscapes: unexpected " ++ e)+  where+    p :: ABL.Parser BL.ByteString+    p = fmap BL.fromChunks $ many $+          (ABL.takeWhile1 (/= 27)) <|>+          (pAnsiEscape $> "") <|>+          (ABL.satisfy (== 27) $> "")+    pAnsiEscape :: ABL.Parser ()+    pAnsiEscape = (ABL.<?> "pAnsiEscape") $ do+      _ <- ABL.satisfy (== 27)  -- '\ESC'+      _ <- ABL.satisfy (== 91)  -- '['+      _ <- ABL.takeWhile (\w -> w == 59 || (w >= 48 && w <= 57)) -- ';' '0'-'9'+      _ <- ABL.satisfy (== 109) -- 'm'+      pure ()++