co-log: Composable Contravariant Comonadic Logging

HASKELL.SG: 6 Dec 2018

by Dmitrii Kovanikov

About me

What I do

Haskell Adept at Holmusk (present)

Contacts

@ChShersh

Haskell Software Developer at Serokell (2016-2018)

Haskell Lecturer at the ITMO University (2015-2018)

Dmitrii Kovanikov

Cofounder, Mentor, Developer at Kowainik (free time)

@chshersh

What this talk about?

Based on my blog post:

➣ co-log: Composable Contravariant Combinatorial Comonadic Configurable Convenient Logging

New and unexplored earlier approach for logging with the help of standard typeclasses that fit naturally to the solution.

Decomposing logging task

➣ What to log: text, message data type, JSON

➣ Where to log: to the terminal, to some file, to an external service

➣ How to format the output: coloured text or JSON

➣ How to log: with logger rotation, only to stderr or something else

➣ What context to work in: pure or some IO

Core data type

                  ┌── monad to perform logging in
                  │
                  │  ┌── type of message to log
                  │  │
newtype LogAction m msg = LogAction
    { unLogAction :: msg -> m ()
    }

logStringStdout :: LogAction IO String
logStringStdout = LogAction putStrLn

Simple examples

logStringStderr :: LogAction IO String
logStringStderr = LogAction $ hPutStrLn stderr

logPrint :: Show a => LogAction IO a
logPrint = LogAction print

Why not?

type LogAction m msg = msg -> m ()

How to use LogAction?

-- very handy operator
infix 5 <&
(<&) :: LogAction m msg -> msg -> m ()
(<&) = coerce

2. Put inside ReaderT environment

1. Pass explicitly as an argument

example :: LogAction IO String -> IO ()
example log = do
    log <& "Application started..."
    threadDelay 5_000_000
    log <& "Job's done!"

➣ To be covered later

Composability

instance Applicative m => Semigroup (LogAction m a) where
    (<>) :: LogAction m a -> LogAction m a -> LogAction m a
    LogAction log1 <> LogAction log2 = LogAction $ \a -> log1 a *> log2 a

Semigroup: perform multiple actions for the same message

logStringOutErr :: LogAction IO String
logStringOutErr = logStringStdout <> logStringStderr

Monoid: empty action that does nothing

instance Applicative m => Monoid (LogAction m a) where
    mempty :: LogAction m a
    mempty = LogAction $ \_ -> pure ()

➣ Useful for disabling logging

Contravariant

class Contravariant f where
    contramap :: (a -> b) -> f b -> f a

Contravariant: consume messages of different types

instance Contravariant (LogAction m) where
    contramap :: (a -> b) -> LogAction m b -> LogAction m a
    contramap f (LogAction action) = LogAction (action . f)

data Message = Message
    { messageText :: String
    , messageTags :: [Tag]
    }

Formatting messages

formatMessage :: Message -> String

logStringStdout :: LogAction IO String
logStringStdout = LogAction putStrLn

logMessageStdout :: LogAction IO Message
logMessageStdout = contramap formatMessage logStringStdout

ContravariantM

cmapM :: Monad m => (a -> m b) -> LogAction m b -> LogAction m a
cmapM f (LogAction action) = LogAction (action <=< f)

contramap f (LogAction action) = LogAction (action  .  f)
cmapM     f (LogAction action) = LogAction (action <=< f)

Compare with contramap

Call additional actions

data Message = Message
    { messageText :: String
    , messageTime :: UTCTime
    }

withTime :: String -> IO Message
withTime txt = do
    now <- getCurrentTime
    pure (Message txt now)

logMessageStdout :: LogAction IO Message

logUTCStringStdout :: LogAction IO String
logUTCStringStdout = cmapM withTime logMessageStdout

Cofilter

cfilter :: Applicative m => (msg -> Bool) -> LogAction m msg -> LogAction m msg
cfilter p (LogAction log) = LogAction $ \msg -> when (p msg) (log msg)

Filter by Severity

data Severity = Debug | Info | Warning | Error
    deriving (Eq, Ord)

data Message = Message
    { messageSeverity :: Severity
    , messageText     :: String
    }

logMessageStdout :: LogAction IO Message

logWarningMessageStdout :: LogAction IO Message
logWarningMessageStdout = cfilter 
    (\(Message sev _) -> sev >= Warning)
    logMessageStdout

Divisible

class Contravariant f => Divisible f where
    conquer :: f a
    divide  :: (a -> (b, c)) -> f b -> f c -> f a

instance Applicative m => Divisible (LogAction m) where
    conquer :: LogAction m a
    conquer = mempty

    divide :: (a -> (b, c)) -> LogAction m b -> LogAction m c -> LogAction m a
    divide f (LogAction logB) (LogAction logC) =
        LogAction $ \(f -> (b, c)) -> logB b *> logC c

Divisible: log both types of messages if you know how to log each one

Decidable

class Divisible f => Decidable f where
    lose   :: (a -> Void) -> f a
    choose :: (a -> Either b c) -> f b -> f c -> f a

instance Applicative m => Decidable (LogAction m) where
    lose :: (a -> Void) -> LogAction m a
    lose f = LogAction (absurd . f)

    choose :: (a -> Either b c) -> LogAction m b -> LogAction m c -> LogAction m a
    choose f (LogAction logB) (LogAction logC) =
        LogAction (either logB logC . f)

Decidable: decide what to log depending on the message

Combinatorial (1 / 2)

data Engine = Pistons Int | Rocket

data Car = Car
    { carMake   :: String
    , carModel  :: String
    , carEngine :: Engine }

(>$<) :: Contravariant f => (b -> a) -> f a -> f b
(>*<) :: Divisible     f => f a -> f b -> f (a, b)
(>|<) :: Decidable     f => f a -> f b -> f (Either a b)
(>*)  :: Divisible     f => f a -> f () -> f a
(*<)  :: Divisible     f => f () -> f a -> f a

stringL :: LogAction IO String
showL   :: Show a => LogAction IO a
constL  :: String -> LogAction IO a
intL    :: LogAction IO Int

engineToEither :: Engine -> Either Int ()
engineToEither = \case
    Pistons i -> Left i
    Rocket    -> Right ()

carToTuple :: Car -> (String, (String, Engine))
carToTuple (Car make model engine) = (make, (model, engine))

Combinatorial (2 / 2)

carL :: LogAction IO Car
carL = carToTuple
  >$< (constL "Logging make..." *< stringL >* constL "Finished logging make...")
  >*< (constL "Logging model.." *< stringL >* constL "Finished logging model...")
  >*< ( engineToEither
    >$< constL "Logging pistons..." *< intL
    >|< constL "Logging rocket..."
      )

ghci> carL <& Car "Toyota" "Corolla" (Pistons 4)
Logging make...
Toyota
Finished logging make...
Logging model..
Corolla
Finished logging model...
Logging pistons...
4

Comonadic

class Functor w => Comonad w where
    extract :: w a -> a
    extend  :: (w a -> b) -> w a -> w b

newtype Traced m a = Traced { runTraced :: m -> a }

instance Monoid m => Comonad (Traced m) where
    extract :: Traced m a -> a
    extract (Traced ma) = ma mempty

    extend :: (Traced m a -> b) -> Traced m a -> Traced m b
    extend f (Traced ma) = Traced $ \m -> f $ Traced $ \m' -> ma (m <> m')

extract :: Monoid msg => LogAction m msg -> m ()
extract (LogAction action) = action mempty

extend
    :: Semigroup msg
    => (LogAction m msg -> m ())
    -> LogAction m msg
    -> LogAction m msg
extend f (LogAction action) =
    LogAction $ \m -> f $ LogAction $ \m' -> action (m <> m')

type LogAction m msg = Traced msg (m ())

Logging with context

ghci> :{
ghci| f :: LogAction IO String -> IO ()
ghci| f (LogAction l) = l ".f1" *> l ".f2"
ghci|
ghci| g :: LogAction IO String -> IO ()
ghci| g (LogAction l) = l ".g"
ghci| :}

ghci> logStringStdout <& "foo"
foo

ghci> extend f logStringStdout <& "foo"
foo.f1
foo.f2

ghci> extend g (extend f logStringStdout) <& "foo"
foo.g.f1
foo.g.f2

Real-world example

What co-log has

class HasLog env msg m where
    getLogAction :: env -> LogAction m msg
    setLogAction :: LogAction m msg -> env -> env

Lens-like typeclass

type WithLog env msg m = (MonadReader env m, HasLog env msg m, HasCallStack)

mtl-like type

logMsg :: forall msg env m . WithLog env msg m => msg -> m ()
logMsg msg = do
    LogAction log <- asks getLogAction
    log msg

General logging function

Messages type + extras

data Message = Message
    { messageSeverity :: Severity
    , messageStack    :: CallStack
    , messageText     :: Text }

Logging function for Message

log :: WithLog env Message m => Severity -> Text -> m ()

What you need to implement

ReaderT environment

data Env m = Env
    { envPort      :: Port
    , envLogAction :: LogAction m Message
    }

ReaderT monad

newtype App a = App
    { runApp :: ReaderT (Env App) IO a 
    } deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Env App))

smsSendTestHandler :: (MonadSms m, WithLog env Message m) => Phone -> m ()
smsSendTestHandler phone = do
    log D $ "Sending test sms to: " <> show phone
    sendSms phone "Test message"

Looks like this

HasLog instance

instance HasLog (Env m) m Message where
    getLogAction = envLogAction
    setLogAction newAction env = env { envLogAction = newAction }

Real example of LogAction

Specification:

1. All logging messages go to terminal.

2. Configure lower Severity threshold for terminal messages.

3. All messages with severity Warning or higher should go to DB.

logMessageApp :: Severity -> LogAction App Message
logMessageApp lowerSev = logMessageStdout lowerSev <> logMessageDB

logMessageStdout :: MonadIO m => Severity -> LogAction m Message
logMessageStdout lowerSeverity =
      cfilter (\(Message sev _) -> sev >= lowerSeverity)
    $ cmapM addTimestamp
    $ cmap formatMessage logTextStdout

logMessageDB :: LogAction App Message
logMessageDB = cfilter (\(Message sev _) -> sev >= Warning) (LogAction logToDB)
  where
    logToDB :: Message -> App ()
    logToDB msg =
        -- insert message into your favourite DB

Real module: 20 LOC for logging configuration

Not covered cool features

Dependent Types + OverloadedLabels + Extensible Records

defaultFieldMap :: MonadIO m => FieldMap m
defaultFieldMap = fromList
    [ #threadId (liftIO myThreadId)
    , #utcTime  (liftIO getCurrentTime)
    ]

type family FieldType (fieldName :: Symbol) :: Type
type instance FieldType "threadId" = ThreadId
type instance FieldType "utcTime"  = UTCTime

newtype MessageField (m :: Type -> Type) (fieldName :: Symbol)
    = MessageField (m (FieldType fieldName))

type FieldMap (m :: Type -> Type) = TypeRepMap (MessageField m)

* a little bit of magic *

data RichMessage (m :: Type -> Type) = RichMessage
    { richMessageMsg :: Message
    , richMessageMap :: FieldMap m
    }

Output example

Conclusion

GitHub: kowainik/co-log

Worlds of logging in Haskell by Vitaly Bragilevsky

Kowainik: typerep-map step by step by Veronika Romashkina

co-log: Composable Contravariant Comonadic Logging

By Dmitrii Kovanikov

co-log: Composable Contravariant Comonadic Logging

1,344

co-log: Composable Contravariant Comonadic Logging

About me

What I do

Contacts

What this talk about?

Decomposing logging task

Core data type

Simple examples

Why not?

How to use LogAction?

2. Put inside ReaderT environment

1. Pass explicitly as an argument

Composability

Contravariant

Formatting messages

ContravariantM

Cofilter

Filter by Severity

Divisible

Decidable

Combinatorial (1 / 2)

Combinatorial (2 / 2)

Comonadic

Logging with context

Real-world example

What co-log has

What you need to implement

Real example of LogAction

Not covered cool features

Output example

Conclusion

co-log: Composable Contravariant Comonadic Logging

More from Dmitrii Kovanikov