SHARE
TWEET

Simple API wrapper around Network.HTTP.Req

Revolucent Sep 18th, 2019 115 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE DataKinds #-}
  2. {-# LANGUAGE DeriveGeneric #-}
  3. {-# LANGUAGE FlexibleContexts #-}
  4. {-# LANGUAGE FlexibleInstances #-}
  5. {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  6. {-# LANGUAGE MultiParamTypeClasses #-}
  7. {-# LANGUAGE OverloadedStrings #-}
  8. {-# LANGUAGE RecordWildCards #-}
  9. {-# LANGUAGE TypeFamilies #-}
  10. {-# LANGUAGE TupleSections #-}
  11.  
  12. module Api (
  13.     Api,
  14.     Connection,
  15.     MonadApi(..),
  16.     call,
  17.     getJ,
  18.     postJ,
  19.     putJ,
  20.     req,
  21.     reqJ,
  22.     reqS,
  23.     withApi,
  24.     withApiConfig,
  25.     withApiHttp,
  26.     withApiHttps,
  27.     withEndpoint,
  28.     withOption,
  29.     withPath,
  30.     withPaths
  31. )
  32.  
  33. where
  34.  
  35. import Control.Applicative
  36. import Control.Monad.Catch
  37. import Control.Monad.IO.Class
  38. import Control.Monad.Reader
  39. import Data.Aeson
  40. import Data.ByteString (ByteString)
  41. import Data.Proxy (Proxy)
  42. import Data.Semigroup hiding (Option)
  43. import Data.Text
  44. import Data.Typeable
  45. import GHC.Generics
  46. import Network.HTTP.Client.MultipartFormData (Part)
  47. import Network.HTTP.Req hiding (req)
  48. import qualified Network.HTTP.Req as Req
  49.  
  50. type Connection scheme = (Url scheme, Option scheme)
  51.  
  52. data InvalidUrlException = InvalidUrlException ByteString deriving (Show, Typeable)
  53. instance Exception InvalidUrlException
  54.  
  55. newtype Api scheme a = Api (ReaderT (Connection scheme) (ReaderT HttpConfig IO) a) deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Connection scheme), MonadCatch, MonadThrow, MonadPlus, Alternative)
  56.  
  57. instance MonadHttp (Api scheme) where
  58.     handleHttpException = throwM
  59.     getHttpConfig = Api $ lift ask
  60.  
  61. class (MonadReader (Connection scheme) m, MonadHttp m) => MonadApi scheme m
  62.  
  63. instance MonadApi scheme (Api scheme)
  64.  
  65. withApiConfig :: MonadIO m => HttpConfig -> Connection scheme -> Api scheme a -> m a
  66. withApiConfig config connection (Api call) = liftIO $ runReaderT (runReaderT call connection) config
  67.  
  68. withApi :: MonadIO m => Connection scheme -> Api scheme a -> m a
  69. withApi = withApiConfig defaultHttpConfig
  70.  
  71. withApiHttp :: (MonadIO m, MonadThrow m) => ByteString -> Api Http a -> m a
  72. withApiHttp url call = case parseUrlHttp url of
  73.     Nothing -> throwM $ InvalidUrlException url
  74.     Just connection -> withApi connection call
  75.  
  76. withApiHttps :: (MonadIO m, MonadThrow m) => ByteString -> Api Https a -> m a
  77. withApiHttps url call = case parseUrlHttps url of
  78.     Nothing -> throwM $ InvalidUrlException url
  79.     Just connection -> withApi connection call
  80.  
  81. withOption :: MonadReader (Connection scheme) m => Option scheme -> m a -> m a
  82. withOption option call = local modify call
  83.     where
  84.         modify (url, options) = (url, options <> option)
  85.  
  86. withPath :: MonadReader (Connection scheme) m => Text -> m a -> m a
  87. withPath path call = local modify call
  88.     where
  89.         modify (url, options) = (url /: path, options)
  90.  
  91. withPaths :: MonadReader (Connection scheme) m => [Text] -> m a -> m a
  92. withPaths [] call = call
  93. withPaths (p:ps) call = withPath p $ withPaths ps call
  94.  
  95. withEndpoint :: MonadReader (Connection scheme) m => Text -> m a -> m a
  96. withEndpoint endpoint = withPaths $ splitOn "/" endpoint
  97.  
  98. call :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body, HttpResponse response) => method -> body -> Proxy response -> m response
  99. call method body response = do
  100.     (url, options) <- ask
  101.     Req.req method url body response options
  102.  
  103. req :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body, HttpResponse response) => method -> body -> Proxy response -> m (HttpResponseBody response)
  104. req method body response = responseBody <$> call method body response
  105.  
  106. reqJ :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body, FromJSON a) => method -> body -> m a
  107. reqJ method body = req method body jsonResponse
  108.  
  109. reqS :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body) => method -> body -> m ByteString
  110. reqS method body = req method body bsResponse
  111.  
  112. req_ :: (MonadApi scheme m, HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body) => method -> body -> m ()
  113. req_ method body = req method body ignoreResponse
  114.  
  115. getJ :: (MonadApi scheme m, FromJSON a) => m a
  116. getJ = reqJ GET NoReqBody
  117.  
  118. getS :: MonadApi scheme m => m ByteString
  119. getS = reqS GET NoReqBody
  120.  
  121. postJ :: (MonadApi scheme m, ToJSON up, FromJSON down) => up -> m down
  122. postJ = reqJ POST . ReqBodyJson
  123.  
  124. postJ_ :: (MonadApi scheme m, ToJSON up) => up -> m ()
  125. postJ_ = req_ POST . ReqBodyJson
  126.  
  127. putJ :: (MonadApi scheme m, ToJSON up, FromJSON down) => up -> m down
  128. putJ = reqJ PUT . ReqBodyJson
  129.  
  130. delete_ :: MonadApi scheme m => m ()
  131. delete_ = req_ DELETE NoReqBody
  132.  
  133. deleteJ :: (MonadApi scheme m, FromJSON a) => m a
  134. deleteJ = req DELETE NoReqBody jsonResponse
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top