Skip to content

Instantly share code, notes, and snippets.

@Revolucent
Last active September 21, 2019 15:08
Show Gist options
  • Save Revolucent/b688b9e1d151c5a0708dd8135f33a876 to your computer and use it in GitHub Desktop.
Save Revolucent/b688b9e1d151c5a0708dd8135f33a876 to your computer and use it in GitHub Desktop.
A simple wrapper around Network.HTTP.Req to talk to an API.
{-# 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
@Revolucent
Copy link
Author

Dependencies are:

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

@Revolucent
Copy link
Author

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment