diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,31 @@ +# Version 0.2 + +* BREAKING CHANGE: `Segment`, `Key`, `Value` and `Message` don't strip + surrounding whitespace anymore. When rendering `Segment`, `Key` and `Value`, + the whitespace will be percent-encoded. When rendering `Message`, the + whitespace will be kept as is. + +* BREAKING CHANGE: `Segment` and `Key` now wrap lazy `Text`, rather than strict + `Text`. This is to align their APIs with `Value` and `Message`, which already + wrapped lazy `Text` so as to prevent logged `Value`s and `Message`s from + to use much memory. It's unlikely that `Segment`s and `Key`s are affected by + this, since in practice they are almost always created statically. So, this + change is mostly to make the API less surprising to users: Lazy `Text` is used + throughout. + +* Added draft BNF specification. + + +# Version 0.1.2 + +* Fixed escaping of control characters in `Message`. + +* Percent-escape less punctuation characters when rendering `Key`, + `Segment` and `Value`. + + TODO: write spec. + + # Version 0.1.1 * Fixed compilation. diff --git a/df1.cabal b/df1.cabal --- a/df1.cabal +++ b/df1.cabal @@ -1,8 +1,8 @@ name: df1 -version: 0.1.1 +version: 0.2 author: Renzo Carbonara maintainer: renĪ»ren.zone -copyright: Renzo Carbonara 2018 +copyright: Renzo Carbonara 2016-2018 license: BSD3 license-file: LICENSE.txt extra-source-files: README.md CHANGELOG.md diff --git a/lib/Df1.hs b/lib/Df1.hs --- a/lib/Df1.hs +++ b/lib/Df1.hs @@ -3,6 +3,27 @@ -- -- Consider this a preview release: The API is likely to stay stable, but -- extensive testing, formalization and tooling is due. +-- +-- Draft [BNF](https://en.wikipedia.org/wiki/Backus%E2%80%93Naur_form) +-- specification of the /df1/ log line format (TO BE VERIFIED): +-- +-- > ::= " " " " " " +-- > ::= " " | | "" +-- > ::= "/" | "=" +-- > ::= zero or more characters until " " +-- > ::= zero or more characters until (" " | "=") +-- > ::= zero or more characters until " " +-- > ::= zero or more characters until LF ("\n") +-- > ::= "DEBUG" | "INFO" | "NOTICE" | "WARNING" | "ERROR" | "CRITICAL" | "ALERT" | "EMERGENCY" +-- > ::= "-" "-" "T" ":" ":" "." "Z" +-- > ::= +-- > ::= +-- > ::= +-- > ::= +-- > ::= +-- > ::= +-- > ::= +-- > ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" module Df1 ( -- * Types T.Log(Log, log_time, log_level, log_path, log_message) diff --git a/lib/Df1/Parse.hs b/lib/Df1/Parse.hs --- a/lib/Df1/Parse.hs +++ b/lib/Df1/Parse.hs @@ -36,10 +36,10 @@ parse :: AB.Parser Log {-# INLINABLE parse #-} parse = (AB. "parse") $ do - t <- AB.skipWhile (== 32) *> pIso8601 + t <- AB.skipWhile (== 32) *> pIso8601 -- :space: p <- AB.skipWhile (== 32) *> pPath l <- AB.skipWhile (== 32) *> pLevel - m <- AB.skipWhile (== 32) *> pMessage + m <- AB.skip (== 32) *> pMessage pure (Log { log_time = Time.utcToSystemTime t , log_level = l, log_path = p, log_message = m }) @@ -128,14 +128,13 @@ pSegment = (AB. "pSegment") $ do AB.skip (== 47) AB. "/" bl <- pUtf8LtoL =<< pDecodePercents =<< AB.takeWhile (/= 32) -- :space: - pure (segment (TL.toStrict bl)) + pure (segment 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)) + pure (key bl) pValue :: AB.Parser Value pValue = (AB. "pValue") $ do diff --git a/lib/Df1/Render.hs b/lib/Df1/Render.hs --- a/lib/Df1/Render.hs +++ b/lib/Df1/Render.hs @@ -12,6 +12,8 @@ import Data.Function (fix) import Data.Monoid ((<>)) import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Time as Time @@ -85,40 +87,97 @@ ps Seq.:|> Push s -> f ps <> slash <> renderSegment s <> space Seq.Empty -> mempty +-- | Escaping rules for 'Segment': +-- +-- * A \'%' anywhere is always percent-escaped (\"%25")" +-- +-- * A 'isControl7' char anywhere is always percent-escaped. 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 +renderMessage x = eall (unMessage x) + where + {-# INLINE eall #-} + eall = TL.encodeUtf8BuilderEscaped + $ BBP.condB (== 37) word8HexPercent -- '%' + $ BBP.condB isControl7 word8HexPercent + $ BBP.liftFixedToBounded BBP.word8 +-- | Escaping rules for 'Segment': +-- +-- * A 'isPunctuation7' in the first character is always percent-escaped. +-- +-- * A 'isPunctuation7' anywhere else is always percent-escaped, unless it is +-- \'-' or \'_'. +-- +-- * A 'isControl7' char anywhere is always percent-escaped. renderSegment :: Segment -> BB.Builder {-# INLINE renderSegment #-} -renderSegment = escapeMetaL . TL.fromStrict . unSegment +renderSegment x = case TL.uncons (unSegment x) of + Nothing -> mempty + Just (hd,tl) -> ehead (T.singleton hd) <> etail tl + where + {-# INLINE ehead #-} + ehead = T.encodeUtf8BuilderEscaped + $ BBP.condB isPunctuation7 word8HexPercent + $ BBP.condB isControl7 word8HexPercent + $ BBP.liftFixedToBounded BBP.word8 + {-# INLINE etail #-} + etail = TL.encodeUtf8BuilderEscaped + $ BBP.condB (\w -> w == 0x2d -- '-' + || w == 0x5f) -- '_' + (BBP.liftFixedToBounded BBP.word8) + $ BBP.condB isPunctuation7 word8HexPercent + $ BBP.condB isControl7 word8HexPercent + $ BBP.liftFixedToBounded BBP.word8 +-- | Escaping rules for 'Key': +-- +-- * A 'isControl7' char anywhere is always percent-escaped. +-- +-- * A 'isPunctuation7' in the first character is always percent-escaped. +-- +-- * A 'isPunctuation7' anywhere else is always percent-escaped, unless it is +-- \'-' or \'_'. renderKey :: Key -> BB.Builder {-# INLINE renderKey #-} -renderKey = escapeMetaL . TL.fromStrict . unKey +renderKey x = case TL.uncons (unKey x) of + Nothing -> mempty + Just (hd,tl) -> ehead (T.singleton hd) <> etail tl + where + {-# INLINE ehead #-} + ehead = T.encodeUtf8BuilderEscaped + $ BBP.condB isPunctuation7 word8HexPercent + $ BBP.condB isControl7 word8HexPercent + $ BBP.liftFixedToBounded BBP.word8 + {-# INLINE etail #-} + etail = TL.encodeUtf8BuilderEscaped + $ BBP.condB (\w -> w == 0x2d -- '-' + || w == 0x5f) -- '_' + (BBP.liftFixedToBounded BBP.word8) + $ BBP.condB isPunctuation7 word8HexPercent + $ BBP.condB isControl7 word8HexPercent + $ BBP.liftFixedToBounded BBP.word8 +-- | Escaping rules for 'Value': +-- +-- * A \' ' anywhere is always percent-escaped (\"%20"). +-- +-- * A \'%' anywhere is always percent-escaped (\"%25")" +-- +-- * A \'=' anywhere is always percent-escaped (\"%3d"). +-- +-- * A 'isControl7' char anywhere is always percent-escaped. 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 +renderValue x = eall (unValue x) + where + {-# INLINE eall #-} + eall = TL.encodeUtf8BuilderEscaped + $ BBP.condB (== 0x20) word8HexPercent + $ BBP.condB (== 0x25) word8HexPercent + $ BBP.condB (== 0x3d) word8HexPercent + $ BBP.condB isControl7 word8HexPercent + $ BBP.liftFixedToBounded BBP.word8 -------------------------------------------------------------------------------- -- Some hardcoded stuff we use time and time again @@ -299,3 +358,17 @@ {-# INLINE _zero6 #-} {-# INLINE _zero7 #-} {-# INLINE _zero8 #-} + +-- | 'True' for all ASCII-7 punctuation characters. +isPunctuation7 :: Word8 -> Bool +{-# INLINE isPunctuation7 #-} +isPunctuation7 w = + (w >= 32 && w <= 47) || + (w >= 58 && w <= 64) || + (w >= 91 && w <= 96) || + (w >= 123 && w <= 126) + +-- | 'True' for ASCII-7 control characters. +isControl7 :: Word8 -> Bool +{-# INLINE isControl7 #-} +isControl7 w = (w <= 31) || (w == 127) diff --git a/lib/Df1/Types.hs b/lib/Df1/Types.hs --- a/lib/Df1/Types.hs +++ b/lib/Df1/Types.hs @@ -12,7 +12,6 @@ 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 @@ -51,17 +50,15 @@ -- \"foo\" :: 'Message' -- @ -- --- Please keep in mind that 'Message' will always strip surrounding whitespace. --- That is: +-- Otherwise, you can use 'fromString' or the 'message' function. -- --- @ --- \"x\" :: 'Message' == \" x\" == \"x \" == \" x \" --- @ +-- Notice that @\"\" :: 'Message'@ is acceptable, and will be correctly rendered +-- and parsed back. newtype Message = Message TL.Text deriving (Eq, Show) message :: TL.Text -> Message -message = Message . TL.dropAround (== ' ') +message = Message {-# INLINE message #-} unMessage :: Message -> TL.Text @@ -130,20 +127,23 @@ -- \"foo\" :: 'Segment' -- @ -- --- Otherwise, you can use 'fromString' or the 'Segment' constructor directly. -newtype Segment = Segment T.Text +-- Otherwise, you can use 'fromString' or the 'segment' function. +-- +-- Notice that @\"\" :: 'Segment'@ is acceptable, and will be correctly rendered +-- and parsed back. +newtype Segment = Segment TL.Text deriving (Eq, Show) -segment :: T.Text -> Segment -segment = Segment . T.dropAround (== ' ') +segment :: TL.Text -> Segment +segment = Segment {-# INLINE segment #-} -unSegment :: Segment -> T.Text +unSegment :: Segment -> TL.Text unSegment = \(Segment x) -> x {-# INLINE unSegment #-} instance IsString Segment where - fromString = segment . T.pack + fromString = segment . TL.pack {-# INLINE fromString #-} instance Semigroup Segment where @@ -169,25 +169,21 @@ -- -- 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 +-- Notice that @\"\" :: 'Key'@ is acceptable, and will be correctly rendered and +-- parsed back. +newtype Key = Key TL.Text deriving (Eq, Show) -key :: T.Text -> Key -key = Key . T.dropAround (== ' ') +key :: TL.Text -> Key +key = Key {-# INLINE key #-} -unKey :: Key -> T.Text +unKey :: Key -> TL.Text unKey = \(Key x) -> x {-# INLINE unKey #-} instance IsString Key where - fromString = key . T.pack + fromString = key . TL.pack {-# INLINE fromString #-} instance Semigroup Key where @@ -213,12 +209,8 @@ -- -- 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 \" --- @ +-- Notice that @\"\" :: 'Value'@ is acceptable, and will be correctly rendered +-- and parsed back. newtype Value = Value TL.Text deriving (Eq, Show) @@ -227,7 +219,7 @@ {-# INLINE unValue #-} value :: TL.Text -> Value -value = Value . TL.dropAround (== ' ') +value = Value {-# INLINE value #-} instance IsString Value where @@ -251,7 +243,7 @@ -- 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 +-- 1999-12-20T07:11:39.230553031Z \/foo x=a y=b \/bar \/qux z=c z=d WARNING Something -- @ -- -- For that line, the 'log_path' attribute of the 'Log' datatype will contain @@ -261,6 +253,7 @@ -- [ 'Push' ('segment' \"foo\") -- , 'Attr' ('key' \"x\") ('value' \"a\") -- , 'Attr' ('key' \"y\") ('value' \"b\") +-- , 'Push' ('segment' \"bar\") -- , 'Push' ('segment' \"qux\") -- , 'Attr' ('key' \"z\") ('value' \"c\") -- , 'Attr' ('key' \"z\") ('value' \"d\") diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -29,13 +29,13 @@ tt :: Tasty.TestTree tt = Tasty.testGroup "df1" - [ Tasty.localOption (QC.QuickCheckTests 1000) $ + [ Tasty.localOption (QC.QuickCheckTests 2000) $ 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) $ + , Tasty.localOption (QC.QuickCheckTests 2000) $ QC.testProperty "Color renders the same content" $ do QC.forAllShrink QC.arbitrary QC.shrink $ \log0 -> do let bl = BB.toLazyByteString (Df1.render log0)