MVar for typed Request-Response

typed_request_response_mvar.hs

{-# language DataKinds #-}
{-# language GADTs #-}
{-# language KindSignatures #-}
{-# language MagicHash #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language TypeFamilies #-}

-- | This is a module illustrating an approach to allow concurrently-running
--   client to interact with a resource that does not support concurrent
--   access. The common approach involves sticking the resource in an
--   MVar and having each client that wants to use it call withMVar. While
--   this does prevent concurrent access, it means that a client that
--   hangs after acquiring the resource would hang every other client that
--   needs the resource. By constrast, the approach illustrated in this
--   module keeps access to the resource on a single thread. Any operation
--   on the resource must be described by the Action data type. This
--   makes it impossible for users to interleave arbitrary computation
--   with operations on the resource.
--
--   There are several possible variations in the design:
--
--   * Request could be a GADT instead of a type family. This
--     gets rid of the need for SingAtom.
--   * There should be a way to close a bus. Closing the bus
--     requires shutting down the worker thread associated
--     with it. It is a little tricky to do this correctly.
--     One option involves adding a Shutdown action to
--     request and making the Shutdown action inaccessible
--     to end users. Another option involving switching
--     from an MVar to a TVar for incoming requests.
--   * It is possible to make the bus polymorphic in its
--     action type and resource. This requires open type
--     families. In the interest of clarity, this option
--     is not pursued here.
module TypedRequestResponseMVar
  ( -- * Type-Safe Bus
    Bus
  , request
  , open
    -- * Example-Specific Data
  , Action(..)
  , RequestMove(..)
  , RequestAttack(..)
  , RequestFlee(..)
  , ResponseMove(..)
  , ResponseAttack(..)
  , ResponseFlee(..)
  , Request
  , Response
  ) where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar,newEmptyMVar,putMVar,takeMVar)
import Control.Monad (forever)
import Data.Kind (Type)
import Data.Proxy (Proxy)

-- | A bus over which clients can send requests. Only one request
--   can be processed at a time. This abstraction is useful for
--   managing concurrent access to a resource in such a way
--   that the clients do not handle the resource directly. They
--   may only issue commands over the bus.
--
--   In a real application, the bus would include another field
--   representing a resource that does not support concurrent
--   access. The purpose of the bus is to guard access to this
--   resource.
newtype Bus = Bus (MVar Payload)

-- Not exported
data Payload :: Type where
  Payload :: forall (a :: Action). SingAction a -> MVar (Response a) -> Request a -> Payload

-- | Issue a request and block until the bus handles the request
--   and responds.
request :: forall a. Bus -> SingAction a -> Request a -> IO (Response a)
request (Bus req) a r = do
  resp <- newEmptyMVar
  putMVar req (Payload a resp r)
  takeMVar resp

-- | Open a bus. This forks a thread on which the bus worker runs.
--   The worker performs the following steps:
--
--   * Wait for a request to arrive.
--   * Handle that one request.
--   * Respond to the client that issued the request.
--
--   Crucially, the worker only ever handles one request at a time.
--   This means that only one action operates on the resource
--   at a time.
--
--   This example does not include a way to close the bus. This
--   could be handled be providing a bracket-style withBus function or by
--   doing something devious with finalizers.
open :: IO Bus
open = do
  m <- newEmptyMVar
  _ <- forkIO (worker m)
  pure (Bus m)

-- Not exported. In this example, the worker calculates the response
-- by applying a pure function to the request. In a real application,
-- the function applied to the request would always be something
-- that used a resource in an effectful way.
worker :: MVar Payload -> IO ()
worker req = forever $ do
  Payload a resp r <- takeMVar req
  putMVar resp (executePurely a r)

----------------------------------------------------------
-- Everything below this point is specific to this example
-- and would not be used in a real application.
----------------------------------------------------------

data Action = Move | Attack | Flee

data SingAction :: Action -> Type where
  SingMove :: SingAction 'Move
  SingAttack :: SingAction 'Attack
  SingFlee :: SingAction 'Flee

newtype RequestMove = RequestMove Int
data RequestAttack = RequestAttack !Int !Int !Bool
data RequestFlee = RequestFlee

data ResponseMove = ResponseMove !Int !Int
data ResponseAttack = ResponseAttack
newtype ResponseFlee = ResponseFlee Bool

type family Request (a :: Action) :: Type where
  Request 'Move = RequestMove
  Request 'Attack = RequestAttack
  Request 'Flee = RequestFlee

type family Response (a :: Action) :: Type where
  Response 'Move = ResponseMove
  Response 'Attack = ResponseAttack
  Response 'Flee = ResponseFlee

executePurely :: SingAction a -> Request a -> Response a
executePurely SingMove (RequestMove x) = ResponseMove (x + 1) (x + 2)
executePurely SingAttack (RequestAttack _ _ _) = ResponseAttack
executePurely SingFlee RequestFlee = ResponseFlee True