A sample Servant + freer Effects server

EffServer.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}

{-| Sample code struggling with reader Eff

uses code from https://github.com/TaktInc/freer
-}
module TestServer where


import           Control.Concurrent.Async
import           Eff
import           Eff.Exc
import           Eff.Exc.Pure
import           Eff.Reader
import           Eff.Reader.Pure
import           Network.HTTP.Client      hiding (Proxy)
import qualified Network.Wai.Handler.Warp as Warp
import           Protolude                hiding (Reader, ask, local, runReader)
import           Servant
import           Servant.Client

-- * Effect

-- | A dummy `Eff`ect's GADT definition
data MyEff a  where
  Frobnicate :: Int  -> MyEff Text

-- | Helper function
frobnicate:: (Member MyEff r) => Int -> Eff r Text
frobnicate = send . Frobnicate

-- | Sample `MyEff` interpreter
-- Will `show` whatever argument is passed to `Frobnicate`.
runMyEff :: (Member (Reader Env) r)
         => Eff (MyEff ': r) a -> Eff r a
runMyEff = handleRelay pure ( \ (Frobnicate i) -> (>>=) $ do
                                e <- theenv <$> ask
                                pure (e <> show i))

-- * Servant

-- | Basic API Type definition
type API = Header "tracing-id" Text :> "foo" :> Capture "bar" Int :> Get '[JSON] Text

api :: Proxy API
api = Proxy

-- | Holds some "local" environment which is dependent upon a request's parameter
data Env = Env { theenv :: Text }

-- | Partial interpreter for standard effects
-- This function is the key to move from the `Eff` world to the `Handler` world
-- expected by Servant. It is a natural transformation from the `Eff r` functor to
-- the `Handler` functor. In servant pre-0.12, it used to be packed into an actual
-- `m ~> n` type provided by @natural-transformations@ package but it is now simply
-- a polymorphic function.
effToHandler :: forall x . Eff '[Exc ServantErr, IO] x -> Handler x
effToHandler = Handler . ExceptT . runM . runError

-- | Server implementation
-- Uses `hoistServer` from Servant 0.13 to interpret handlers into the Servant world
server = serve api (hoistServer api effToHandler handlers)
  where

    -- We define a local handler to be able to inject a custom `Reader` environment
    -- for each request. This is useful for example, when propagating tracing ids
    -- across a distributed services network
    runHandlers :: forall r x . Env -> Eff (MyEff : Reader Env : r) x -> Eff r x
    runHandlers env = runReader env . runMyEff

    -- Simple handlers definition.
    -- We need to wrap each handler into `runHandlers` to ensure environment is local
    -- and available for all interpreters run in that context
    handlers (Just t) i = runHandlers (Env t) $ frobnicate i
    handlers Nothing  i = runHandlers (Env "") $ frobnicate i

-- | Basic Servant Client
foobar :: Maybe Text -> Int -> ClientM Text
foobar = client api

test :: IO ()
test = do
  s <- async $ Warp.run 8888 server
  env <- ClientEnv <$> newManager defaultManagerSettings <*> pure (BaseUrl Http "localhost" 8888 "")
  r <- runClientM (foobar (Just "tid") 12) env

  putStrLn ("Right \"tid12\" =?= " <> show r :: [Char])

  cancel s