module Control.Monad.Freer.Http
( Http
, get
, getJSON
, post
, postJSON
, doRequest
, request
, requestJSON
, HttpException
, JSONParseError(..)
, runHttp
, mockHttp
, staticHttpMock
)
where
import Control.Exception
import Control.Monad
import Control.Monad.Freer
import Control.Monad.Freer.Error
import Data.Aeson
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Functor ((<&>))
import Network.HTTP.Client (Request, Response, Manager, httpLbs
,HttpException(HttpExceptionRequest), parseRequest, requestHeaders
,method, path, HttpExceptionContent(StatusCodeException)
,RequestBody(..), requestBody)
import Network.HTTP.Client.Internal (Response(..), CookieJar(CJ), ResponseClose(..))
import Network.HTTP.Types.Header (RequestHeaders)
import Network.HTTP.Types.Method (Method, methodGet, methodPost)
import Network.HTTP.Types.Status (Status, status404, statusCode)
import Network.HTTP.Types.Version (http11)
data Http v where
DoRequest :: Request -> Http (Response ByteString)
ParseRequest :: String -> Http Request
DoRequestJSON :: (FromJSON a) => Request -> Http a
TryRequestJSON :: (FromJSON a) => Request -> Http (Either JSONParseError a)
doRequest :: Member Http r => Request -> Eff r (Response ByteString)
doRequest req = send (DoRequest req)
parseReq :: Member Http r => String -> Eff r Request
parseReq = send . ParseRequest
doRequestJSON :: (Member Http r, FromJSON a) => Request -> Eff r a
doRequestJSON = send . DoRequestJSON
tryRequestJSON :: (Member Http r, FromJSON a) => Request -> Eff r (Either JSONParseError a)
tryRequestJSON = send . TryRequestJSON
request :: (Member Http r)
=> Method
-> RequestHeaders
-> String
-> Maybe RequestBody
-> Eff r (Response ByteString)
request meth headers url body = do
req <- parseReq url
doRequest req
{ requestHeaders = headers
, method = meth
, requestBody = fromMaybe mempty body
}
newtype JSONParseError = JSONParseError String deriving (Show)
requestJSON :: (FromJSON resp, ToJSON req
,Member Http r
)
=> Method
-> RequestHeaders
-> String
-> Maybe req
-> Eff r resp
requestJSON meth headers url mBody = do
let body = maybe mempty (RequestBodyLBS . encode) mBody
req <- parseReq url <&> \req -> req { requestHeaders = headers
, method = meth
, requestBody = body
}
doRequestJSON req
get :: (Member Http r)
=> String -> Eff r (Response ByteString)
get url = request methodGet [] url Nothing
getJSON :: (FromJSON a, Member Http r)
=> String -> Eff r a
getJSON url = requestJSON methodGet [] url (Nothing @())
post :: (Member Http r)
=> String -> RequestBody -> Eff r (Response ByteString)
post url = request methodPost [] url . Just
postJSON :: (FromJSON resp, ToJSON req, Member Http r)
=> String -> req -> Eff r resp
postJSON url = requestJSON methodPost [("Content-Type", "application/json")] url . Just
runHttp :: forall r w
. (Member IO r, Member (Error HttpException) r, Member (Error JSONParseError) r)
=> Manager
-> Eff (Http ': r) w
-> Eff r w
runHttp mgr eff = interpret handler eff
where
handler :: Http a -> Eff r a
handler (DoRequest req) = send $ httpLbs req mgr
handler (ParseRequest str) = send $ parseRequest @IO str
handler (DoRequestJSON req) = do
response <- handler (DoRequest req)
let code = statusCode $ responseStatus response
unless (200 <= code && code < 300) $
throwError (HttpExceptionRequest req $ StatusCodeException (() <$ response) "")
let body = responseBody response
case eitherDecode body of
Left err -> throwError $ JSONParseError err
Right val -> return val
mockHttp :: Eff (Http ': r) w -> (Request -> Response ByteString) -> Eff r w
mockHttp eff f = interpret (\(DoRequest req) -> return (f req)) eff
staticHttpMock :: Eff (Http ': r) w -> Map (Method, BS.ByteString) (Status, ByteString) -> Eff r w
staticHttpMock eff endpoints = mockHttp eff findEndpoint
where findEndpoint req = case M.lookup (method req, path req) endpoints of
Nothing -> Response status404 http11 [] "" (CJ []) (ResponseClose $ return ())
Just (s, b) -> Response s http11 [] b (CJ []) (ResponseClose $ return ())