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