A simple wrapper around Network.HTTP.Req to talk to an API.

Api.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}

module Api (
    Api,
    Connection,
    MonadApi(..),
    call,
    getJ,
    postJ,
    putJ,
    req,
    reqJ,
    reqS,
    withApi,
    withApiConfig,
    withApiHttp,
    withApiHttps,
    withEndpoint,
    withOption,
    withPath,
    withPaths,
    (/->),
    (<-/)
)

where

import Control.Applicative
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Proxy (Proxy)
import Data.Semigroup hiding (Option)
import Data.Text
import Data.Typeable
import GHC.Generics
import Network.HTTP.Client.MultipartFormData (Part)
import Network.HTTP.Req hiding (req)
import qualified Network.HTTP.Req as Req

type Connection scheme = (Url scheme, Option scheme)

data InvalidUrlException = InvalidUrlException ByteString deriving (Show, Typeable)
instance Exception InvalidUrlException

newtype Api scheme a = Api (ReaderT (Connection scheme) (ReaderT HttpConfig IO) a) deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Connection scheme), MonadCatch, MonadThrow, MonadPlus, Alternative)

instance MonadHttp (Api scheme) where
    handleHttpException = throwM
    getHttpConfig = Api $ lift ask 

class (MonadReader (Connection scheme) m, MonadHttp m) => MonadApi scheme m where
    localHttpConfig :: MonadApi scheme m => (HttpConfig -> HttpConfig) -> m a -> m a

instance MonadApi scheme (Api scheme) where
    localHttpConfig t (Api call) = Api $ do 
        connection <- ask
        config <- t <$> lift ask
        liftIO $ runReaderT (runReaderT call connection) config

withApiConfig :: MonadIO m => HttpConfig -> Connection scheme -> Api scheme a -> m a
withApiConfig config connection (Api call) = liftIO $ runReaderT (runReaderT call connection) config

withApi :: MonadIO m => Connection scheme -> Api scheme a -> m a
withApi = withApiConfig defaultHttpConfig

withApiHttp :: (MonadIO m, MonadThrow m) => ByteString -> Api Http a -> m a
withApiHttp url call = case parseUrlHttp url of
    Nothing -> throwM $ InvalidUrlException url
    Just connection -> withApi connection call

withApiHttps :: (MonadIO m, MonadThrow m) => ByteString -> Api Https a -> m a
withApiHttps url call = case parseUrlHttps url of
    Nothing -> throwM $ InvalidUrlException url
    Just connection -> withApi connection call

withOption :: MonadReader (Connection scheme) m => Option scheme -> m a -> m a 
withOption option call = local modify call 
    where
        modify (url, options) = (url, options <> option)

withPath :: MonadReader (Connection scheme) m => Text -> m a -> m a
withPath path call = local modify call
    where
        modify (url, options) = (url /: path, options) 

withPaths :: MonadReader (Connection scheme) m => [Text] -> m a -> m a
withPaths [] call = call
withPaths (p:ps) call = withPath p $ withPaths ps call

withEndpoint :: MonadReader (Connection scheme) m => Text -> m a -> m a
withEndpoint endpoint = withPaths $ splitOn "/" endpoint 

infixl 5 /->

(/->) :: MonadReader (Connection scheme) m => Text -> m a -> m a
(/->) = withEndpoint

infixl 5 <-/

(<-/) :: MonadReader (Connection scheme) m => m a -> Text -> m a
(<-/) = flip withEndpoint

call :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body, HttpResponse response) => method -> body -> Proxy response -> m response 
call method body response = do
    (url, options) <- ask
    Req.req method url body response options

req :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body, HttpResponse response) => method -> body -> Proxy response -> m (HttpResponseBody response) 
req method body response = responseBody <$> call method body response

reqJ :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body, FromJSON a) => method -> body -> m a 
reqJ method body = req method body jsonResponse

reqS :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body) => method -> body -> m ByteString 
reqS method body = req method body bsResponse 

req_ :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body) => method -> body -> m () 
req_ method body = req method body ignoreResponse 

getJ :: (MonadApi scheme m, FromJSON a) => m a 
getJ = reqJ GET NoReqBody

getS :: MonadApi scheme m => m ByteString
getS = reqS GET NoReqBody

postJ :: (MonadApi scheme m, ToJSON up, FromJSON down) => up -> m down
postJ = reqJ POST . ReqBodyJson

postJ_ :: (MonadApi scheme m, ToJSON up) => up -> m ()
postJ_ = req_ POST . ReqBodyJson

putJ :: (MonadApi scheme m, ToJSON up, FromJSON down) => up -> m down
putJ = reqJ PUT . ReqBodyJson 

delete_ :: MonadApi scheme m => m ()
delete_ = req_ DELETE NoReqBody

deleteJ :: (MonadApi scheme m, FromJSON a) => m a 
deleteJ = req DELETE NoReqBody jsonResponse 

Dependencies are:

- aeson
- base >= 4.7 && < 5
- bytestring
- data-default
- exceptions
- filepath
- http-client
- mtl
- req
- split
- text

Examples:

main = withApiHttps "https://httpbin.org" $ do 
    getJSON :: Value <- withPath "get" getJ
    liftIO $ print getJSON

Also…

data BinResponse = BinResponse {
    binResponseOrigin :: String,
    binResponseUrl :: String,
    binResponseHeaders :: Map String String
} deriving Show

instance FromJSON BinResponse where
    parseJSON = withObject "httpbin response" $ \o -> do
        binResponseOrigin <- o .: "origin"
        binResponseUrl <- o .: "url"
        binResponseHeaders <- o .: "headers"
        return BinResponse{..}

getBinResponse :: MonadApi scheme m => m BinResponse
getBinResponse = withPath "get" getJ

main :: IO ()
main = withApiHttps "https://httpbin.org" $ getBinResponse >>= liftIO . print