Types.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

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)
   , ToPath (path)
   , Segment
   , unSegment
   , ToSegment (segment)
   , Key
   , unKey
   , ToKey (key)
   , Value
   , unValue
   , ToValue (value)
   , Message
   , unMessage
   , ToMessage (message)
   ) where

import Control.Exception (SomeException)
import Data.Coerce (coerce)
import qualified Data.Fixed as Fixed
import Data.Foldable (toList)
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Semigroup (Semigroup ((<>)))
import Data.Sequence as Seq
import Data.String (IsString (fromString))
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Time as Time
import qualified Data.Time.Clock.System as Time
import qualified Data.Time.Format.ISO8601 as Time
import Data.Word (Word16, Word32, Word64, Word8)
import Numeric.Natural (Natural)

--------------------------------------------------------------------------------

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'
-- @
--
-- Otherwise, you can use 'fromString' or 'message'.
--
-- Notice that @\"\" :: 'Message'@ is acceptable, and will be correctly rendered
-- and parsed back.
newtype Message = Message TL.Text
   deriving (Eq, Show)

unMessage :: Message -> TL.Text
unMessage = coerce
{-# INLINE unMessage #-}

instance IsString Message where
   fromString = message
   {-# INLINE fromString #-}

instance Semigroup Message where
   (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text)
   {-# INLINE (<>) #-}

instance Monoid Message where
   mempty = Message mempty
   {-# INLINE mempty #-}

-- | Convert an arbitrary type to a 'Message'.
--
-- You are encouraged to create custom 'ToMessage' 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 ToMessage a where
   message :: a -> Message

-- | Identity.
instance ToMessage Message where
   message = id
   {-# INLINE message #-}

-- |
-- @
-- x :: 'TL.Text' == 'unMessage' ('message' x)
-- @
instance ToMessage TL.Text where
   message = Message
   {-# INLINE message #-}

-- |
-- @
-- 'TB.toLazyText' (x :: 'TB.Builder') == 'unMessage' ('message' x)
-- @
instance ToMessage TB.Builder where
   message = Message . TB.toLazyText
   {-# INLINE message #-}

-- |
-- @
-- x :: 'T.Text' == 'TL.toStrict' ('unMessage' ('message' x))
-- @
instance ToMessage T.Text where
   message = Message . TL.fromStrict
   {-# INLINE message #-}

-- |
-- @
-- x :: 'String' == 'TL.unpack' ('unMessage' ('message' x))
-- @
instance ToMessage String where
   message = Message . TL.pack
   {-# INLINE message #-}

instance ToMessage SomeException where
   message = message . show
   {-# INLINE message #-}

--------------------------------------------------------------------------------

-- | 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
   = -- | Message intended to be useful only when deliberately debugging a program.
     Debug
   | -- | Informational message.
     Info
   | -- | A condition that is not an error, but should possibly be handled
     -- specially.
     Notice
   | -- | A warning condition, such as an exception being gracefully handled or
     -- some missing configuration setting being assigned a default value.
     Warning
   | -- | Error condition, such as an unhandled exception.
     Error
   | -- | Critical condition that could result in system failure, such as a disk
     -- running out of space.
     Critical
   | -- | A condition that should be corrected immediately, such as a corrupted
     -- database.
     Alert
   | -- | System is unusable.
     Emergency
   deriving (Eq, Show, Read, 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 'segment'.
--
-- Notice that @\"\" :: 'Segment'@ is acceptable, and will be correctly rendered
-- and parsed back.
newtype Segment = Segment TL.Text
   deriving (Eq, Show)

unSegment :: Segment -> TL.Text
unSegment = coerce
{-# INLINE unSegment #-}

instance IsString Segment where
   fromString = segment
   {-# INLINE fromString #-}

instance Semigroup Segment where
   (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text)
   {-# INLINE (<>) #-}

instance Monoid Segment where
   mempty = Segment mempty
   {-# INLINE mempty #-}

-- | Convert an arbitrary type to a 'Segment'.
--
-- You are encouraged to create custom 'ToSegment' 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 ToSegment a where
   segment :: a -> Segment

-- | Identity.
instance ToSegment Segment where
   segment = id
   {-# INLINE segment #-}

-- |
-- @
-- x :: 'TL.Text' == 'unSegment' ('segment' x)
-- @
instance ToSegment TL.Text where
   segment = Segment
   {-# INLINE segment #-}

-- |
-- @
-- 'TB.toLazyText' (x :: 'TB.Builder') == 'unSegment' ('segment' x)
-- @
instance ToSegment TB.Builder where
   segment = Segment . TB.toLazyText
   {-# INLINE segment #-}

-- |
-- @
-- x :: 'T.Text' == 'TL.toStrict' ('unSegment' ('segment' x))
-- @
instance ToSegment T.Text where
   segment = Segment . TL.fromStrict
   {-# INLINE segment #-}

-- |
-- @
-- x :: 'String' == 'TL.unpack' ('unSegment' ('segment' x))
-- @
instance ToSegment String where
   segment = Segment . TL.pack
   {-# INLINE segment #-}

instance ToSegment Char where
   segment = Segment . TL.singleton
   {-# INLINE segment #-}

--------------------------------------------------------------------------------

-- | 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 'key'.
--
-- Notice that @\"\" :: 'Key'@ is acceptable, and will be correctly rendered and
-- parsed back.
newtype Key = Key TL.Text
   deriving (Eq, Show)

unKey :: Key -> TL.Text
unKey = coerce
{-# INLINE unKey #-}

instance IsString Key where
   fromString = key
   {-# INLINE fromString #-}

instance Semigroup Key where
   (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text)
   {-# INLINE (<>) #-}

instance Monoid Key where
   mempty = Key mempty
   {-# INLINE mempty #-}

-- | Convert an arbitrary type to a 'Key'.
--
-- You are encouraged to create custom 'ToKey' 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 ToKey a where
   key :: a -> Key

-- | Identity.
instance ToKey Key where
   key = id
   {-# INLINE key #-}

-- |
-- @
-- x :: 'TL.Text' == 'unKey' ('key' x)
-- @
instance ToKey TL.Text where
   key = Key
   {-# INLINE key #-}

-- |
-- @
-- 'TB.toLazyText' (x :: 'TB.Builder') == 'unKey' ('key' x)
-- @
instance ToKey TB.Builder where
   key = Key . TB.toLazyText
   {-# INLINE key #-}

-- |
-- @
-- x :: 'T.Text' == 'TL.toStrict' ('unKey' ('key' x))
-- @
instance ToKey T.Text where
   key = Key . TL.fromStrict
   {-# INLINE key #-}

-- |
-- @
-- x :: 'String' == 'TL.unpack' ('unKey' ('key' x))
-- @
instance ToKey String where
   key = Key . TL.pack
   {-# INLINE key #-}

instance ToKey Char where
   key = Key . TL.singleton
   {-# INLINE key #-}

--------------------------------------------------------------------------------

-- | 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 'value'.
--
-- Notice that @\"\" :: 'Value'@ is acceptable, and will be correctly rendered
-- and parsed back.
newtype Value = Value TL.Text
   deriving (Eq, Show)

unValue :: Value -> TL.Text
unValue = coerce
{-# INLINE unValue #-}

instance IsString Value where
   fromString = value
   {-# INLINE fromString #-}

instance Semigroup Value where
   (<>) = coerce ((<>) :: TL.Text -> TL.Text -> TL.Text)
   {-# INLINE (<>) #-}

instance Monoid Value where
   mempty = Value mempty
   {-# INLINE mempty #-}

-- | Convert an arbitrary type to a 'Value'.
--
-- You are encouraged to create custom 'ToValue' 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 ToValue a where
   value :: a -> Value

-- | Identity.
instance ToValue Value where
   value = id
   {-# INLINE value #-}

-- |
-- @
-- x :: 'TL.Text' == 'unValue' ('value' x)
-- @
instance ToValue TL.Text where
   value = Value
   {-# INLINE value #-}

-- |
-- @
-- 'TB.toLazyText' (x :: 'TB.Builder') == 'unValue' ('value' x)
-- @
instance ToValue TB.Builder where
   value = Value . TB.toLazyText
   {-# INLINE value #-}

-- |
-- @
-- x :: 'T.Text' == 'TL.toStrict' ('unValue' ('value' x))
-- @
instance ToValue T.Text where
   value = Value . TL.fromStrict
   {-# INLINE value #-}

-- |
-- @
-- x :: 'String' == 'TL.unpack' ('unValue' ('value' x))
-- @
instance ToValue String where
   value = Value . TL.pack
   {-# INLINE value #-}

instance ToValue SomeException where
   value = value . show
   {-# INLINE value #-}
instance ToValue Bool where
   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 #-}
instance ToValue Int8 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Int16 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Int32 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Int64 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Word where
   value = value . show
   {-# INLINE value #-}
instance ToValue Word8 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Word16 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Word32 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Word64 where
   value = value . show
   {-# INLINE value #-}
instance ToValue Integer where
   value = value . show
   {-# INLINE value #-}
instance ToValue Natural where
   value = value . show
   {-# INLINE value #-}
instance ToValue Float where
   value = value . show
   {-# INLINE value #-}
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"

--------------------------------------------------------------------------------

-- | '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 \/bar \/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' \"bar\")
-- , '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)

-- | 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 #-}