Pasted

{-# 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 
 
instance MonadApi scheme (Api scheme)
 
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 
 
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