{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module      : Servant.Polysemy.Client
Copyright   : (c) 2020 Alex Chapman
License     : BSD3
Maintainer  : alex@farfromthere.net
Stability   : experimental
Portability : GHC
Description : A Polysemy effect for running Servant commands (ClientM).

This module allows you to act as a client of a Servant API, within a Polysemy 'Sem'.
Use the servant-client package to generate your clients, which return in the 'ClientM' monad.
You can then use 'runClient' (or 'runClientStreaming') to run your client in 'Sem', and 'runServantClient' (or 'runServantClientStreaming') to interpret the effect.

See <example/Client.hs> for a simple example that can interact with the example servers in the same directory.
-}
module Servant.Polysemy.Client
  (
  -- * Effects
  -- ** Non-Streaming
    ServantClient
  , runClient'
  , runClient

  -- ** Streaming
  , ServantClientStreaming
  , runClientStreaming

  -- * Interpreters
  -- ** Non-Streaming
  , runServantClientUrl
  , runServantClient

  -- ** Streaming
  , runServantClientStreamingUrl
  , runServantClientStreaming

  -- * Re-exported from Servant
  , ClientError
  ) where

import Control.DeepSeq (NFData)
import Control.Monad ((>=>))
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Polysemy
import Polysemy.Cont
import Polysemy.Error
import Servant.Client.Streaming
       ( BaseUrl
       , ClientError
       , ClientM
       , mkClientEnv
       , parseBaseUrl
       , runClientM
       , withClientM
       )

-- | The 'ServantClient' effect allows you to run a 'ClientM' as automatically generated for your API by the servant-client package.
data ServantClient m a where
  RunClient' :: NFData o => ClientM o -> ServantClient m (Either ClientError o)

makeSem ''ServantClient

-- | Run this 'ClientM' in the 'Sem' monad.
runClient
  :: (Members '[ServantClient, Error ClientError] r, NFData o)
  => ClientM o -> Sem r o
runClient :: ClientM o -> Sem r o
runClient = ClientM o -> Sem r (Either ClientError o)
forall (r :: [Effect]) o.
(MemberWithError ServantClient r, NFData o) =>
ClientM o -> Sem r (Either ClientError o)
runClient' (ClientM o -> Sem r (Either ClientError o))
-> (Either ClientError o -> Sem r o) -> ClientM o -> Sem r o
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Either ClientError o -> Sem r o
forall e (r :: [Effect]) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither

-- | Interpret the 'ServantClient' effect by running any calls to 'RunClient'' against the given 'BaseUrl'.
runServantClientUrl
  :: Member (Embed IO) r
  => BaseUrl -> Sem (ServantClient ': r) a -> Sem r a
runServantClientUrl :: BaseUrl -> Sem (ServantClient : r) a -> Sem r a
runServantClientUrl server :: BaseUrl
server m :: Sem (ServantClient : r) a
m = do
  Manager
manager <- IO Manager -> Sem r Manager
forall (m :: * -> *) (r :: [Effect]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Manager -> Sem r Manager) -> IO Manager -> Sem r Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  let env :: ClientEnv
env = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
server
  (forall x (m :: * -> *). ServantClient m x -> Sem r x)
-> Sem (ServantClient : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret (\case
    RunClient' client ->
      IO (Either ClientError o) -> Sem r x
forall (m :: * -> *) (r :: [Effect]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either ClientError o) -> Sem r x)
-> IO (Either ClientError o) -> Sem r x
forall a b. (a -> b) -> a -> b
$ ClientM o -> ClientEnv -> IO (Either ClientError o)
forall a.
NFData a =>
ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM o
client ClientEnv
env
    ) Sem (ServantClient : r) a
m

-- | Parse the given string as a URL and then behave as 'runServantClientUrl' does.
runServantClient
  :: Member (Embed IO) r
  => String -> Sem (ServantClient ': r) a -> Sem r a
runServantClient :: String -> Sem (ServantClient : r) a -> Sem r a
runServantClient server :: String
server m :: Sem (ServantClient : r) a
m = do
  BaseUrl
server' <- IO BaseUrl -> Sem r BaseUrl
forall (m :: * -> *) (r :: [Effect]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO BaseUrl -> Sem r BaseUrl) -> IO BaseUrl -> Sem r BaseUrl
forall a b. (a -> b) -> a -> b
$ String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
server
  BaseUrl -> Sem (ServantClient : r) a -> Sem r a
forall (r :: [Effect]) a.
Member (Embed IO) r =>
BaseUrl -> Sem (ServantClient : r) a -> Sem r a
runServantClientUrl BaseUrl
server' Sem (ServantClient : r) a
m

-- | The 'ServantClientStreaming' effect is just like the 'ServantClient' effect,
-- but allows streaming connections.
data ServantClientStreaming m a where
  RunClientStreaming :: ClientM o -> ServantClientStreaming m o

makeSem ''ServantClientStreaming

-- | Interpret the 'ServantClientStreaming' effect by running any calls to 'RunClientStreaming' against the given URL.
-- Note that this adds a 'Cont' effect, which you can interpret using 'runContM', probably just before your call to 'runM'.
runServantClientStreamingUrl
  :: Members
    '[ Cont ref
     , Embed IO
     , Error ClientError
     ] r
  => BaseUrl -> Sem (ServantClientStreaming ': r) a -> Sem r a
runServantClientStreamingUrl :: BaseUrl -> Sem (ServantClientStreaming : r) a -> Sem r a
runServantClientStreamingUrl server :: BaseUrl
server m :: Sem (ServantClientStreaming : r) a
m = do
  Manager
manager <- IO Manager -> Sem r Manager
forall (m :: * -> *) (r :: [Effect]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Manager -> Sem r Manager) -> IO Manager -> Sem r Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  let env :: ClientEnv
env = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
server
  (forall x (m :: * -> *). ServantClientStreaming m x -> Sem r x)
-> Sem (ServantClientStreaming : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret (\case
    RunClientStreaming client ->
      (ref (Either ClientError x) -> Sem r x)
-> (Either ClientError x -> Sem r x) -> Sem r x
forall (ref :: * -> *) a b (r :: [Effect]).
Member (Cont ref) r =>
(ref a -> Sem r b) -> (a -> Sem r b) -> Sem r b
subst (\continue :: ref (Either ClientError x)
continue ->
        ((forall x. Sem r x -> IO x) -> IO () -> IO x) -> Sem r x
forall (r :: [Effect]) a.
Member (Embed IO) r =>
((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
withLowerToIO (((forall x. Sem r x -> IO x) -> IO () -> IO x) -> Sem r x)
-> ((forall x. Sem r x -> IO x) -> IO () -> IO x) -> Sem r x
forall a b. (a -> b) -> a -> b
$ \unliftIO :: forall x. Sem r x -> IO x
unliftIO _ ->
          ClientM x -> ClientEnv -> (Either ClientError x -> IO x) -> IO x
forall a b.
ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM ClientM x
client ClientEnv
env (Sem r x -> IO x
forall x. Sem r x -> IO x
unliftIO (Sem r x -> IO x)
-> (Either ClientError x -> Sem r x)
-> Either ClientError x
-> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ref (Either ClientError x) -> Either ClientError x -> Sem r x
forall (ref :: * -> *) a b (r :: [Effect]).
Member (Cont ref) r =>
ref a -> a -> Sem r b
jump ref (Either ClientError x)
continue)
        ) Either ClientError x -> Sem r x
forall e (r :: [Effect]) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither
    ) Sem (ServantClientStreaming : r) a
m

-- | Parse the given string as a URL and then behave as 'runServantClientStreamingUrl'.
runServantClientStreaming
 :: Members
    '[ Cont ref
     , Embed IO
     , Error ClientError
     ] r
  => String -> Sem (ServantClientStreaming ': r) a -> Sem r a
runServantClientStreaming :: String -> Sem (ServantClientStreaming : r) a -> Sem r a
runServantClientStreaming server :: String
server m :: Sem (ServantClientStreaming : r) a
m = do
  BaseUrl
server' <- IO BaseUrl -> Sem r BaseUrl
forall (m :: * -> *) (r :: [Effect]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO BaseUrl -> Sem r BaseUrl) -> IO BaseUrl -> Sem r BaseUrl
forall a b. (a -> b) -> a -> b
$ String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
server
  BaseUrl -> Sem (ServantClientStreaming : r) a -> Sem r a
forall (ref :: * -> *) (r :: [Effect]) a.
Members '[Cont ref, Embed IO, Error ClientError] r =>
BaseUrl -> Sem (ServantClientStreaming : r) a -> Sem r a
runServantClientStreamingUrl BaseUrl
server' Sem (ServantClientStreaming : r) a
m