diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,19 @@ +# Version 0.4.1 + +* Add `ToPath`, `path`. + +* Add `ToValue` instances for `base`'s `Char`, `Fixed`; for `time`'s + `SystemTime`, `UTCTime`, `CalendarDiffDays`, `CalendarDiffTime`, `Day`, + `TimeZone`, `TimeOfDay`, `LocalTime`, `ZonedTime`, `NominalDiffTime`, + `DiffTime`, `DayOfWeek`. + +* Add `ToSegment` instances for `base`'s `Char`. + +* Add `ToKey` instances for `base`'s `Char`. + +* Add `Read` instance for `Level`. + + # Version 0.4 * COMPILER ASSISTED BREAKING CHANGE: Change functions names `Df1.render` to diff --git a/df1.cabal b/df1.cabal --- a/df1.cabal +++ b/df1.cabal @@ -1,5 +1,5 @@ name: df1 -version: 0.4 +version: 0.4.1 author: Renzo Carbonara maintainer: renĪ»ren.zone copyright: Renzo Carbonara 2016 @@ -8,7 +8,7 @@ extra-source-files: README.md CHANGELOG.md category: Logging build-type: Simple -cabal-version: >=1.18 +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 diff --git a/lib/Df1.hs b/lib/Df1.hs --- a/lib/Df1.hs +++ b/lib/Df1.hs @@ -28,12 +28,16 @@ ( -- * 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.Path(Attr, Push), T.ToPath(path) , T.Segment, T.unSegment, T.ToSegment(segment) , T.Key, T.unKey, T.ToKey(key) , T.Value, T.unValue, T.ToValue(value) , T.Message, T.unMessage, T.ToMessage(message) ) where +import Df1.Render () -- To make sure module instances are available here too. +import Df1.Parse () -- To make sure module instances are available here too. + import qualified Df1.Types as T + diff --git a/lib/Df1/Parse.hs b/lib/Df1/Parse.hs --- a/lib/Df1/Parse.hs +++ b/lib/Df1/Parse.hs @@ -21,6 +21,8 @@ import Data.Word (Word8, Word16, Word32) import Prelude hiding (log) +import Df1.Render () -- To make sure module instances are available here too. + import Df1.Types (Log(Log, log_time, log_level, log_path, log_message), Level(Debug, Info, Notice, Warning, Error, Critical, Alert, Emergency), diff --git a/lib/Df1/Render.hs b/lib/Df1/Render.hs --- a/lib/Df1/Render.hs +++ b/lib/Df1/Render.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Df1.Render ( log @@ -16,7 +17,7 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Prim as BBP import Data.Function (fix) -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) import qualified Data.Sequence as Seq import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -33,8 +34,9 @@ Path(Attr, Push), Segment, unSegment, Key, unKey, - Value, unValue, + Value, unValue, ToValue, Message, unMessage) +import qualified Df1.Types (value) -------------------------------------------------------------------------------- @@ -73,7 +75,7 @@ -- 2019-11-15T18:05:54.949640299Z \/server port=80 INFO Listening for new clients -- 2019-11-15T18:05:54.949652133Z \/server port=80 \/handler client-address=10.0.0.8 INFO Connection established -- 2019-11-15T18:05:54.949664482Z \/server port=80 \/handler client-address=10.0.0.8 WARNING user error (Oops!) --- @ +-- @ log :: Log -> BB.Builder {-# INLINABLE log #-} log = \x -> @@ -108,7 +110,7 @@ -- -- * A \'%\' anywhere is always percent-escaped (\"%25\") -- --- * An ASCII-7 control character anywhere is always percent-escaped. +-- * An ASCII-7 control character anywhere is always percent-escaped. -- -- The output is encoded as UTF-8. message :: Message -> BB.Builder @@ -128,7 +130,7 @@ -- * An ASCII-7 punctuation character anywhere else is always percent-escaped, unless it is -- \'-\' or \'_\'. -- --- * An ASCII-7 control character anywhere is always percent-escaped. +-- * An ASCII-7 control character anywhere is always percent-escaped. -- -- The output is encoded as UTF-8. segment :: Segment -> BB.Builder @@ -336,9 +338,20 @@ -- The rendered string is 30 characters long, and it's encoded as ASCII/UTF-8. iso8601 :: Time.SystemTime -> BB.Builder {-# INLINE iso8601 #-} -iso8601 = \syst -> - let Time.UTCTime tday tdaytime = Time.systemToUTCTime syst - (year, month, day) = Time.toGregorian tday +iso8601 syst = + iso8601SystemTimeUTCTime syst (Time.systemToUTCTime syst) + +-- | Like 'iso8601', but takes a 'Time.UTCTime'. +iso8601UTCTime :: Time.UTCTime -> BB.Builder +{-# INLINE iso8601UTCTime #-} +iso8601UTCTime utct = + iso8601SystemTimeUTCTime (Time.utcToSystemTime utct) utct + +-- | INTERNAL. Used by 'iso8601' and 'iso8601UTCTime'. +iso8601SystemTimeUTCTime :: Time.SystemTime -> Time.UTCTime -> BB.Builder +{-# INLINE iso8601SystemTimeUTCTime #-} +iso8601SystemTimeUTCTime syst (Time.UTCTime tday tdaytime) = + let (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 @@ -402,3 +415,16 @@ isControl7 :: Word8 -> Bool {-# INLINE isControl7 #-} isControl7 w = (w <= 31) || (w == 127) + +-------------------------------------------------------------------------------- + +-- | See 'iso8601'. +instance ToValue Time.SystemTime where + value = Df1.Types.value . TL.decodeUtf8 . BB.toLazyByteString . iso8601 + {-# NOINLINE value #-} + +-- | See 'iso8601'. +instance ToValue Time.UTCTime where + value = Df1.Types.value . TL.decodeUtf8 . BB.toLazyByteString . iso8601UTCTime + {-# NOINLINE value #-} + diff --git a/lib/Df1/Types.hs b/lib/Df1/Types.hs --- a/lib/Df1/Types.hs +++ b/lib/Df1/Types.hs @@ -6,7 +6,7 @@ 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) + , Path(Attr, Push), ToPath(path) , Segment, unSegment, ToSegment(segment) , Key, unKey, ToKey(key) , Value, unValue, ToValue(value) @@ -14,6 +14,9 @@ ) where import Control.Exception (SomeException) +import Data.Coerce (coerce) +import qualified Data.Fixed as Fixed +import Data.Foldable (toList) import Data.Semigroup (Semigroup((<>))) import Data.Sequence as Seq import qualified Data.Text as T @@ -22,7 +25,9 @@ import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Data.String (IsString(fromString)) +import qualified Data.Time as Time import qualified Data.Time.Clock.System as Time +import qualified Data.Time.Format.ISO8601 as Time -------------------------------------------------------------------------------- @@ -66,7 +71,7 @@ deriving (Eq, Show) unMessage :: Message -> TL.Text -unMessage = \(Message x) -> x +unMessage = coerce {-# INLINE unMessage #-} instance IsString Message where @@ -74,14 +79,12 @@ {-# INLINE fromString #-} instance Semigroup Message where - (<>) (Message a) (Message b) = Message (a <> b) + (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text) {-# INLINE (<>) #-} instance Monoid Message where mempty = Message mempty {-# INLINE mempty #-} - mappend (Message a) (Message b) = Message (mappend a b) - {-# INLINE mappend #-} -- | Convert an arbitrary type to a 'Message'. -- @@ -154,7 +157,7 @@ -- database. | Emergency -- ^ System is unusable. - deriving (Eq, Show, Bounded, Enum) + deriving (Eq, Show, Read, Bounded, Enum) -- | Order of importance. For example, 'Emergency' is more important than -- 'Debug': @@ -183,7 +186,7 @@ deriving (Eq, Show) unSegment :: Segment -> TL.Text -unSegment = \(Segment x) -> x +unSegment = coerce {-# INLINE unSegment #-} instance IsString Segment where @@ -191,14 +194,12 @@ {-# INLINE fromString #-} instance Semigroup Segment where - (<>) (Segment a) (Segment b) = Segment (a <> b) + (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text) {-# INLINE (<>) #-} instance Monoid Segment where mempty = Segment mempty {-# INLINE mempty #-} - mappend (Segment a) (Segment b) = Segment (mappend a b) - {-# INLINE mappend #-} -- | Convert an arbitrary type to a 'Segment'. -- @@ -240,6 +241,10 @@ segment = Segment . TL.pack {-# INLINE segment #-} +instance ToSegment Char where + segment = Segment . TL.singleton + {-# INLINE segment #-} + -------------------------------------------------------------------------------- -- | An attribute key (see 'Attr'). @@ -259,7 +264,7 @@ deriving (Eq, Show) unKey :: Key -> TL.Text -unKey = \(Key x) -> x +unKey = coerce {-# INLINE unKey #-} instance IsString Key where @@ -267,14 +272,12 @@ {-# INLINE fromString #-} instance Semigroup Key where - (<>) (Key a) (Key b) = Key (a <> b) + (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text) {-# INLINE (<>) #-} instance Monoid Key where mempty = Key mempty {-# INLINE mempty #-} - mappend (Key a) (Key b) = Key (mappend a b) - {-# INLINE mappend #-} -- | Convert an arbitrary type to a 'Key'. -- @@ -316,6 +319,10 @@ key = Key . TL.pack {-# INLINE key #-} +instance ToKey Char where + key = Key . TL.singleton + {-# INLINE key #-} + -------------------------------------------------------------------------------- -- | An attribute value (see 'Attr'). @@ -335,7 +342,7 @@ deriving (Eq, Show) unValue :: Value -> TL.Text -unValue = \(Value x) -> x +unValue = coerce {-# INLINE unValue #-} instance IsString Value where @@ -343,14 +350,12 @@ {-# INLINE fromString #-} instance Semigroup Value where - (<>) (Value a) (Value b) = Value (a <> b) + (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text) {-# INLINE (<>) #-} instance Monoid Value where mempty = Value mempty {-# INLINE mempty #-} - mappend (Value a) (Value b) = Value (mappend a b) - {-# INLINE mappend #-} -- | Convert an arbitrary type to a 'Value'. -- @@ -395,11 +400,12 @@ instance ToValue SomeException where value = value . show {-# INLINE value #-} - instance ToValue Bool where - value = \b -> if b then Value "true" else Value "false" + value = \b -> if b then "true" else "false" {-# INLINE value #-} - +instance ToValue Char where + value = Value . TL.singleton + {-# INLINE value #-} instance ToValue Int where value = value . show {-# INLINE value #-} @@ -442,6 +448,56 @@ instance ToValue Double where value = value . show {-# INLINE value #-} +-- | Chops trailing zeros. +instance Fixed.HasResolution a => ToValue (Fixed.Fixed a) where + value = value . Fixed.showFixed True + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.CalendarDiffDays where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.CalendarDiffTime where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.Day where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.TimeZone where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.TimeOfDay where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.LocalTime where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | See 'Time.ISO8601'. +instance ToValue Time.ZonedTime where + value = value . Time.iso8601Show + {-# INLINE value #-} +-- | @123456s@ +instance ToValue Time.NominalDiffTime where + value = value . show + {-# INLINE value #-} +-- | @123456s@ +instance ToValue Time.DiffTime where + value = value . show + {-# INLINE value #-} +-- | Lowercase @monday@, @tuesday@, etc. +instance ToValue Time.DayOfWeek where + value = \x -> case x of + Time.Monday -> "monday" + Time.Tuesday -> "tuesday" + Time.Wednesday -> "wednesday" + Time.Thursday -> "thursday" + Time.Friday -> "friday" + Time.Saturday -> "saturday" + Time.Sunday -> "sunday" -------------------------------------------------------------------------------- @@ -474,3 +530,30 @@ | Attr !Key !Value deriving (Eq, Show) +-- | Convert an arbitrary type to a 'Seq'uence of 'Path's. +-- +-- You are encouraged to create custom 'ToPath' instances for your types +-- making sure you avoid rendering sensitive details such as passwords, so that +-- they don't accidentally end up in logs. +-- +-- Any characters that need to be escaped for rendering will be automatically +-- escaped at rendering time. You don't need to escape them here. +class ToPath a where + -- | The leftmost 'Path' is the closest to the root. The rightmost 'Path' is + -- the one closest to where the log was generated. + -- + -- See the documentation for 'Path'. + path :: a -> Seq.Seq Path + +-- | Identity. +instance ToPath (Seq.Seq Path) where + path = id + {-# INLINE path #-} + +-- | +-- @ +-- 'path' = 'Seq.fromList' . 'toList' +-- @ +instance {-# OVERLAPPABLE #-} Foldable f => ToPath (f Path) where + path = Seq.fromList . toList + {-# INLINE path #-}