{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- Module      :  Polysemy.Req
-- Copyright   :  (C) 2021 Morrow
-- License     :  BSD3-3-Clause
-- Maintainer  :  Morrow <themorrowm@gmail.com>
-- "Network.HTTP.Req" adapted for use with polysemy.
module Polysemy.Req
  ( -- * Effect
    Req (..),

    -- * Actions
    req,

    -- * Interpretations
    interpretReq,
    interpretReqWith,

    -- * Re-exports
    module Network.HTTP.Req,
  )
where

import Data.Proxy
import Network.HTTP.Req hiding (MonadHttp, Req, req, req', reqBr, reqCb, runReq)
import qualified Network.HTTP.Req as R
import Polysemy

-- | An effect for making http 'Network.HTTP.Req.req'uests.
-- @since 0.1.0
data Req m response where
  Req ::
    ( HttpMethod method,
      HttpBody body,
      HttpResponse response,
      HttpBodyAllowed (AllowsBody method) (ProvidesBody body)
    ) =>
    -- | HTTP method
    method ->
    -- | 'Url'—location of resource
    Url scheme ->
    -- | Body of the request
    body ->
    -- | A hint how to interpret response
    Proxy response ->
    -- | Collection of optional parameters
    Option scheme ->
    -- | Response
    Req m response

-- | See 'Network.HTTP.Req.req'.
-- @since 0.1.0
makeSem ''Req

-- | Run a 'Req' effect with the 'Network.HTTP.Req.defaultHttpConfig'.
-- @since 0.1.0
interpretReq :: Member (Embed IO) r => InterpreterFor Req r
interpretReq :: InterpreterFor Req r
interpretReq = HttpConfig -> InterpreterFor Req r
forall (r :: [Effect]).
Member (Embed IO) r =>
HttpConfig -> InterpreterFor Req r
interpretReqWith HttpConfig
defaultHttpConfig

-- | Run a 'Req' effect with a custom 'Network.HTTP.Req.HttpConfig'.
-- @since 0.1.0
interpretReqWith :: Member (Embed IO) r => HttpConfig -> InterpreterFor Req r
interpretReqWith :: HttpConfig -> InterpreterFor Req r
interpretReqWith HttpConfig
cfg = (forall x (rInitial :: [Effect]). Req (Sem rInitial) x -> Sem r x)
-> Sem (Req : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [Effect]). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [Effect]). Req (Sem rInitial) x -> Sem r x)
 -> Sem (Req : r) a -> Sem r a)
-> (forall x (rInitial :: [Effect]).
    Req (Sem rInitial) x -> Sem r x)
-> Sem (Req : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Req m u b p o -> forall (r :: [Effect]) a. Member (Embed IO) r => IO a -> Sem r a
forall (m :: * -> *) (r :: [Effect]) a.
Member (Embed m) r =>
m a -> Sem r a
embed @IO (IO x -> Sem r x) -> IO x -> Sem r x
forall a b. (a -> b) -> a -> b
$ HttpConfig -> Req x -> IO x
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
R.runReq HttpConfig
cfg (Req x -> IO x) -> Req x -> IO x
forall a b. (a -> b) -> a -> b
$ method -> Url scheme -> body -> Proxy x -> Option scheme -> Req x
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
R.req @R.Req method
m Url scheme
u body
b Proxy x
p Option scheme
o