Servant handled using free monads of coproducts of functors :)

README.md

"The point of this is..."

The idea is to use different functors to represent different noninteracting parts of the logic. We expose a user-facing API, transform computations targeting that API into internal APIs -- DB connectors, calls to remote APIs, etc. -- and then combine and handle the final computation at the end using separate, isolated handlers which can depend on what environment it's running in!

This code has a public API (AppF and the AppEffect types). It also has multiple internal APIs: a DbHandlerF, an EmailHandlerF, and a RemoteHandlerF (for remote API calls). The APIs for working with these are all pure, and are separate from each other. Each of these APIs is also separated from its handler, which executes code written for it in IO (and this need not even be an IO action: one can write a different set of "pure" handlers easily).

We also want to be able to swap these pieces in and out. This example allows you to change Providers, which are like "data sources" associated to different Envs the app can run in. Here, I've written a fake DB controller (DbHandlerF) using a concurrently-accessed list of users, and associated it to a Prod environment (although it should've been named Testing: I realised this late enough that I didn't bother to do the replacing.)

"It's actually useful!"

If one writes a real DB controller with, say, sqlite-simple (or, you know, opaleye or other "real" libraries), it should be very easy to replace the current DbHandlerF:

• Write the type

  data SqliteHandlerF next = AddSqliteRecord Thing1 Thing2 next 
                           | QuerySqliteRecord Thing1 Thing2 (Vector User -> next) 
                           | ...
  data SqliteHandler = Free SqliteF

• Write a handler that converts operations in SqliteHandler to IO actions.

• Make SqliteHandlerF an instance of FunctorBackend. Most of this is covered by the previous point; you just have to specify a couple of type family instances (e.g. the Container would be Vector) and lift the operations in SqliteF into the free monad:

  addRecord = liftF $ AddSqliteRecord ...

• Change

  instance HasHandler Prod where
    type ProviderF Prod = DbHandlerF

  to

  instance HasHandler Prod where
    type ProviderF Prod = SqliteHandlerF

but...

Now, what I'd planned was that we could just add a new Env instead of having to replace the behavior of Prod, but we get overlapping instance/"enable IncoherentInstances even though it won't help, lol" problems if the app function is left polymorphic in the Env (because there are multiple ways to deduce a HasServer instance based on the env variable). I think newtyping and adding a clever deriving instance declaration ought to fix this.

Even then,

You can try things like:

$ curl -X GET http://localhost:8080/users/
$ curl -X GET http://localhost:8080/users/add/Person/McPersonface

Ideas

• (somewhat silly) Write a LogHandler that the higher-level components (DB, email, etc.) can interpret to (i.e. instead of adding a LoggingT layer to BaseM, they could work in FreeT LogHandlerF BaseM or something). This kind of structuring gives us something like ... an intermediate language, if you will. servant Core, anyone? :)

  This allows us to transform and handle the log requests as we wish, and any changes here don't affect any other part of the code. More importantly, I think this will make it very easy to have a lot of context for each logging event (in case of an error, say).

Apologies

This is influenced a lot by the well-known John De Goes article, but his approach of writing a separate interpreter for each functor's free monad isn't very useful here, because that forces you to convert each public API call into one set of DB actions, one set of logging actions, and so on, and then perform each set of actions separately one by one. Of course, not being able to interleave IO actions dynamically is sort of limiting (free applicatives? wink), so I decided to try something else. (This code also reminds me of Halogen, now that I think about it. My entire experience with Halogen extends to a few buttons with state that I dimly remember having written once upon a time, so I don't know how conscious that could have been.)

The code is very hacky (e.g. the ContainerRef nonsense (although that could, admittedly, be used to replace the TVar [User] with an STM (Set User) from stm-containers for multithreaded access in test environments, or an IO DBConnection for real-world usage)), has lots of cruft (comments, remnants of "can I remove this Proxy?" experiments, "correct" type annotations) I've forgotten to delete, and is far from complete (for one, most of the MonadBackend constraints aren't being used as well as they should: I should be using them to abstract over different final monads instead of restricting to BaseM).

Also, I spent a long time wondering where Data.Functor.Sum had run off to. I think it took me an hour. (It's in base nowadays, not transformers. On the plus side, I learned that transformers uses Darcs. Huh.)

Liege.hs

{-# LANGUAGE ApplicativeDo           #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE DeriveFunctor           #-}
{-# LANGUAGE DeriveGeneric           #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE IncoherentInstances     #-}
{-# LANGUAGE InstanceSigs            #-}
{-# LANGUAGE KindSignatures          #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE RankNTypes              #-}
{-# LANGUAGE RecordWildCards         #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE StandaloneDeriving      #-}
{-# LANGUAGE TemplateHaskell         #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeFamilyDependencies  #-}
{-# LANGUAGE TypeOperators           #-}

module Liege where

import           Control.Concurrent.STM
import           Control.Monad
import           Control.Monad.Free
import           Control.Monad.Reader
import           Control.Monad.Trans.Free (FreeT, iterT)
import           Data.Aeson
import           Data.Aeson.TH
import           Data.Functor.Sum
import           GHC.Exts                 (Constraint)
import           GHC.Generics
import           Prelude                  hiding (log)

import           Network.Wai
import           Network.Wai.Handler.Warp
import           Servant                  hiding (Handler)
import qualified Servant
import           Servant.Server

-- import           Control.Monad.Trans.Class
-- import           Control.Monad.Writer.Strict
-- import           Control.Monad.Trans.State.Strict

main :: IO ()
main = startApp 8080

data User = User
  { userId        :: Int
  , userFirstName :: String
  , userLastName  :: String
  } deriving (Eq, Show, Generic)

$(deriveJSON defaultOptions ''User)

defaultUsers :: [User]
defaultUsers = [User 1 "Isaac" "Newton", User 2 "Albert" "Einstein"]

type ContainerEnv env = Container (ProviderF env)

type API env =  "users" :> Get '[JSON] (ContainerEnv env User)
           :<|> "users" :> "add"
                        :> Capture "first" String :> Capture "second" String
                        :> Get '[JSON] User

startApp :: Int -> IO ()
startApp port = do
  putStrLn $ "Starting app on port " ++ show port
  state <- initialAppState
  run port $ productionApp state

type HasExecutor env = (HasHandler env, HasInterpreter env)

environment :: Env
environment = Prod

api
  :: forall (env :: Env).
     Proxy env -> Proxy (API env)
api prod = Proxy

-- app
--   :: forall (env :: Env).
--      HasExecutor env
--   => Proxy env -> AppState env -> Application
-- app env state = serve (api env) $ server env state

productionApp
  :: AppState Prod -> Application
productionApp state = serve (api env) $ server env state
  where env = Proxy :: Proxy Prod

-- testApp
--   :: AppState Test -> Application
-- testApp state = serve (api env) $ server env state
--   where env = Proxy :: Proxy Test

server
  :: HasExecutor env
  => Proxy env -> AppState env -> Server (API env)
server env state = enter (nat env state) (server' env)

server'
  :: HasExecutor env
  => Proxy env -> ServerT (API env) (AppEffectEnv env)
server' env = getUsers :<|> addUser
  where
    getUsers :: AppEffectEnv env (Container (ProviderF env) User)
    getUsers = listUsers

    -- addUser :: Proxy env -> String -> String -> AppEffectEnv env User
    -- addUser env f l = do
    addUser :: String -> String -> AppEffectEnv env User
    addUser f l = do
      userList <- listUsers
      let user = User 0 f l
      createUser user
      pure user

nat
  :: (HasHandler env, HasInterpreter env)
  => Proxy env -> AppState env -> AppEffectEnv env :~> Servant.Handler
nat _ state = Nat $ \action ->
  liftIO $ executeUnsafe state action

{- |
  Main application handler
-}

newtype AppState (env :: Env) = AppState
  { users :: ContainerRef (ProviderF env) (Container (ProviderF env) User)
  }

data Env = Prod | Test

class HasHandler (env :: Env) where
  type ProviderF env = (f :: * -> *) | f -> env
  initialAppState :: (MonadIO m) => m (AppState env)
  -- handleAll :: MonadBackend (ProviderF env) n => AppHandlerM env a -> n a
  handleAll :: AppHandlerM env a -> BaseM env a

instance HasHandler Prod where
  type ProviderF Prod = DbHandlerF

  initialAppState
    :: (MonadIO m) => m (AppState Prod)
  initialAppState = do
    state <- liftIO $ atomically $ newTVar defaultUsers
    pure AppState {users = state}

  -- handleAll :: MonadBackend DbHandlerF n => AppHandlerM Prod a -> n a
  handleAll = handleProd

    -- handleAll'
    --   :: (HasExecutor env, MonadBackend (ProviderF env) m)
    --   => AppHandlerF env (BaseM env a) -> m a

handleProd :: AppHandlerM Prod a -> BaseM Prod a
handleProd = iterT handleAll'
  where
    handleAll' :: AppHandlerF Prod (BaseM Prod a) -> BaseM Prod a
    handleAll' eff = join $ (handleRemote ^+^ handleDb ^+^ handleEmail) eff

data AppF (f :: * -> *) a
  = CreateUser User a
  | ListUsers (Container f User -> a)
  | GetExchangeRate String (Double -> a)
  | Overload a
  deriving (Functor)

type AppEffect f = Free (AppF f)

-- | Ideally, don't rely on the app being run in some particular environment.
-- | This is the rank-2 type trick from the ST monad. 
newtype SafeAppEffectF a = SafeAppEffectF
  { unSafeAppEffect :: forall f. FunctorBackend f => AppF f a
  } deriving Functor
type SafeAppEffect = Free SafeAppEffectF

type AppFEnv env = AppF (ProviderF env)
type AppEffectEnv env = Free (AppFEnv env)

class Functor f => FunctorBackend f where
  type Container f = (b :: * -> *) | b -> f
  type MonadBackend f (m :: * -> *) :: Constraint
  type ContainerRef f :: (* -> *)
  -- type ContainerRef f = (r :: * -> *) | r -> f
  addRecord :: User -> Free f ()
  queryRecords :: String -> Free f (Container f User)
  handleDb :: MonadBackend f m => f a -> m a

-- | Convenience wrappers

createUser :: User -> AppEffectEnv env ()
createUser path = liftF (CreateUser path ())

listUsers :: AppEffectEnv env (Container (ProviderF env) User)
listUsers = liftF (ListUsers id)

overload :: AppEffectEnv env ()
overload = liftF $ Overload ()

getExchangeRate :: String -> AppEffect f Double
getExchangeRate url = liftF $ GetExchangeRate url id

-- program :: AppEffect f ()
-- program = do
--   getExchangeRate "http://example.com"
--   listUsers
--   createUser $ head defaultUsers

class FunctorBackend (ProviderF env) =>
      HasInterpreter (env :: Env) where
  interpretAll :: AppEffect (ProviderF env) a -> AppHandler env a

instance HasInterpreter Prod where
  interpretAll :: AppEffect DbHandlerF a -> AppHandler Prod a
  interpretAll = foldFree interpretAll'
    where
      interpretAll' :: AppF DbHandlerF a -> AppHandler Prod a
      interpretAll' (CreateUser user next) = do
        liftDb $ addRecord user
        pure next
      interpretAll' (ListUsers next) =
        next <$> liftDb (queryRecords "*")
      interpretAll' (GetExchangeRate url next) =
        (next . read) <$> liftRemote (remoteCall url)
      interpretAll' op@(Overload next) = do
        liftEmail $
          sendEmail
            Email
            { sender = "[email protected]"
            , recipient = "[email protected]"
            , text = "trouble"
            }
        pure next

      liftRemote = hoistFree InL
      liftEmail = hoistFree InR . hoistFree InR
      liftDb = hoistFree InR . hoistFree InL

-- | -----------------
-- | Database handlers
-- | -----------------

data DbHandlerF a
  = AddRecord User a
  | QueryRecords String ([User] -> a)
  deriving (Functor)

type DbHandler = Free DbHandlerF

instance FunctorBackend DbHandlerF where
  type Container DbHandlerF = []
  type ContainerRef DbHandlerF = TVar
  -- | this Prod is bad
  type MonadBackend DbHandlerF m = (MonadReader (AppState Prod) m, MonadIO m)

  addRecord user = liftF $ AddRecord user ()
  queryRecords query = liftF $ QueryRecords query id
  handleDb (AddRecord user next) = do
    currentState <- asks users
    liftIO $ atomically $ modifyTVar' currentState (user:)
    pure next
  handleDb (QueryRecords query next) = do
    liftIO $ putStrLn $ "query: " ++ query
    currentState <- asks users >>= (liftIO . atomically . readTVar)
    pure $ next currentState

-- | --------------
-- | Email handlers
-- | --------------

data Email = Email
  { sender    :: String
  , text      :: String
  , recipient :: String
  } deriving (Show)

data EmailHandlerF a
  = SendEmail Email a
  deriving (Functor)

type EmailHandler = Free EmailHandlerF

sendEmail email = liftF $ SendEmail email ()

handleEmail :: EmailHandlerF a -> BaseM env a
handleEmail = liftIO . handleEmail'
  where
    handleEmail' (SendEmail Email {..} next) = do
      putStrLn $ "Sending email to " ++ recipient ++ " about " ++ show text
      pure next

-- | -------------------
-- | Remote API handlers
-- | -------------------

data RemoteHandlerF next
  = RemoteCall String (String -> next)
  deriving (Functor)

type RemoteHandler = Free RemoteHandlerF

remoteCall :: String -> RemoteHandler String
remoteCall url = liftF $ RemoteCall url id

handleRemote :: RemoteHandlerF a -> BaseM env a
handleRemote (RemoteCall url next) = liftIO $ do
  putStrLn "calling api"
  let reply = "totally real reply"
  pure $ next reply

-- | -----------------------------------------
-- | The handler for the final interpreted AST
-- | -----------------------------------------

type (<+>) = Sum
infixr 9 <+>

coproduct
  :: (f a -> b)
  -> (g a -> b)
  -> (f <+> g) a -> b
coproduct left _ (InL l)  = left l
coproduct _ right (InR r) = right r

(^+^) = coproduct
infixr ^+^

type BaseT env m = ReaderT (AppState env) m
type BaseM env = BaseT env IO

type AppHandlerF e = RemoteHandlerF <+> ProviderF e <+> EmailHandlerF
type AppHandler  e = Free (AppHandlerF e)
type AppHandlerM e = FreeT (AppHandlerF e) (BaseM e)

executeUnsafe
  :: HasExecutor env
  => AppState env -> AppEffectEnv env a -> IO a
executeUnsafe initialState ops = runReaderT program initialState
  where
    ast = interpretAll ops
    program = handleAll $ toFreeT ast