The Handle Pattern (All credit to Jasper Van der Jeugt)

handle_pattern.md

The Handle Pattern

This pattern is design for qualified import this is why all types are called the same (Database.Handle, Socket.Handle, Database.Config, Secket.Config, ...)

A database Handle

What you need:

• A type called Handle

data Handle = Handle
    { hPool   :: Pool Postgres.Connection
    , hCache  :: IORef (PSQueue Int Text User)
    , hLogger :: Logger.Handle  -- Another handle!
    , …
    }

-- Use it qualified: Database.createUser
createUser :: Handle -> Text -> IO User
createUser = …

getUserMail :: Handle -> User -> IO [Mail]
getUserMail = …

• All functions take the Handle as a first arguments:

-- KO
Database.createUser (userName <> "@" <> companyDomain) database

-- OK
Database.createUser database $ userName <> "@" <> companyDomain

Creating a handle:

• We need a configuration for our handle (usually pure code):

-- This is up to you
parseConfig :: x -> y -> IO Config
parseConfig = ....

data Config = Config
    { cPath :: FilePath
		, …
		}

-- Useful
instance Monoid Config

Always provide a function called new:

new :: Config         -- 1. Config
    -> Logger.Handle  -- 2. Dependencies
    -> …              --    (usually other handles)
    -> IO Handle      -- 3. Result

Destroying the handle

You don't usually want to wait until the GC destroys the reference and frees the resources.

It's a good idea to provide a close function:

close :: Handle -> IO ()
close = …

Reasonable safety

It's usually a good idea to provide this. Even only providing (hiding new, close) is fine.

-- Implement it using bracket
withHandle
    :: Config            -- 1. Config
    -> Logger.Handle     -- 2. Dependencies
    -> …                 --    (usually other handles)
    -> (Handle -> IO a)  -- 3. Function to apply
    -> IO a              -- 4. Result, handle is closed automatically

Summary of the module

module MyApp.Database
    ( Config (..)   -- Internals exported
    , parseConfig   -- Or some other way to load a config

    , Handle        -- Internals usually not exported
    , new
    , close
    , withHandle

    , createUser  -- Actual functions on the handle
    , …
    ) where

A Handle Interface

module MyApp.Database
    ( Handle (..)  -- We now need to export this
    ) where

data Handle = Handle
    { createUser :: Text -> IO User
    , …
    }

-- What’s the type of createUser now?
createUser :: Handle -> Text -> IO User
-- It's exactly the same as before

Compared to other approaches

-- | Create JSON-RPC session around conduits from transport layer.
-- When context exits session disappears.
runJsonRpcT
    :: (MonadLoggerIO m, MonadBaseControl IO m)
    => Ver                  -- ^ JSON-RPC version
    -> Bool                 -- ^ Ignore incoming requests/notifs
    -> Sink ByteString m () -- ^ Sink to send messages
    -> Source m ByteString  -- ^ Source to receive messages from
    -> JsonRpcT m a         -- ^ JSON-RPC action
    -> m a                  -- ^ Output of action

-- v.s.

JsonRpc.Handle

Here is a real project using the Handle Pattern: https://github.com/jaspervdj/fugacious/blob/master/lib/Fugacious/Logger.hs

Source: https://jaspervdj.be/posts/2018-03-08-handle-pattern.html

handle_pattern_example.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-- Source: https://github.com/jaspervdj/fugacious/blob/master/lib/Fugacious/Logger.hs
module Fugacious.Logger
    ( Verbosity (..)
    , Config (..)
    , Handle
    , withHandle

    , debug
    , info
    , warning
    , error

    , debug'
    , info'
    , warning'
    , error'
    ) where

import           Control.Applicative   (Alternative (..))
import           Control.Exception     (bracket)
import qualified Data.Aeson            as A
import           Data.Maybe            (fromMaybe)
import qualified Data.Text             as T
import           Prelude               hiding (error, log)
import qualified System.Log.FastLogger as FL

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

instance A.FromJSON Verbosity where
    parseJSON = A.withText "FromJSON Fugacious.Logger.Verbosity" $ \t ->
        case t of
            "debug"   -> pure Debug
            "info"    -> pure Info
            "warning" -> pure Warning
            "error"   -> pure Error
            _         -> fail $ "Unknown verbosity: " ++ T.unpack t

data Config = Config
    { cPath      :: Maybe FilePath
    , cVerbosity :: Maybe Verbosity
    } deriving (Show)

instance Monoid Config where
    mempty                              = Config empty empty
    Config p0 v0 `mappend` Config p1 v1 = Config (p0 <|> p1) (v0 <|> v1)

instance A.FromJSON Config where
    parseJSON = A.withObject "FromJSON Fugacious.Logger.Config" $ \o -> Config
        <$> o A..:? "path"
        <*> o A..:? "verbosity"

data Handle = Handle
    { hConfig    :: Config
    , hLoggerSet :: FL.LoggerSet
    }

withHandle :: Config -> (Handle -> IO a) -> IO a
withHandle config f = bracket
    (case cPath config of
        Nothing   -> FL.newStderrLoggerSet FL.defaultBufSize
        Just "-"  -> FL.newStderrLoggerSet FL.defaultBufSize
        Just path -> FL.newFileLoggerSet FL.defaultBufSize path)
    FL.rmLoggerSet
    (\l -> f Handle {hConfig = config, hLoggerSet = l})

log :: FL.ToLogStr s => Handle -> Verbosity -> s -> IO ()
log Handle {..} v x
    | v >= verbosity = FL.pushLogStrLn hLoggerSet $ FL.toLogStr x
    | otherwise      = return ()
  where
    verbosity = fromMaybe Debug (cVerbosity hConfig)

debug, info, warning, error :: FL.ToLogStr str => Handle -> str -> IO ()
debug   h = log h Debug
info    h = log h Info
warning h = log h Warning
error   h = log h Error

debug', info', warning', error' :: Handle -> String -> IO ()
debug'   = debug
info'    = info
warning' = warning
error'   = error