Language/Symantic/HTTP/Client.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE Rank2Types #-}
   6 {-# LANGUAGE StrictData #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 module Language.Symantic.HTTP.Client where
  10
  11 -- import Network.HTTP.Media (MediaType, matches, parseAccept, (//))
  12 -- import Servant.API (MimeUnrender, contentTypes, mimeUnrender)
  13 import Data.Default.Class (Default(..))
  14 import Control.Applicative (Applicative(..))
  15 import Control.Monad (Monad(..), unless)
  16 import Control.Monad.Trans.Class (MonadTrans(..))
  17 import Data.Bool
  18 import Data.Either (Either(..))
  19 import Data.Eq (Eq(..))
  20 import Data.Proxy (Proxy(..))
  21 import Data.Foldable (null, for_, toList, any)
  22 import Data.Function (($), (.))
  23 import Data.Functor (Functor)
  24 import Data.Maybe (Maybe(..), maybe)
  25 import Data.Ord (Ord(..))
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.Sequence (Seq)
  28 import Data.String (IsString(..))
  29 import Data.Text (Text)
  30 import Data.Tuple (fst)
  31 import System.IO (IO)
  32 import Text.Read (readMaybe)
  33 import Text.Show (Show(..))
  34 import qualified Control.Concurrent.STM as STM
  35 import qualified Control.Exception as Exn
  36 import qualified Control.Monad.Classes as MC
  37 import qualified Control.Monad.Trans.Except as E
  38 import qualified Control.Monad.Trans.Reader as R
  39 import qualified Data.ByteString as BS
  40 import qualified Data.ByteString.Builder as BSB
  41 import qualified Data.ByteString.Lazy as BSL
  42 import qualified Data.List as List
  43 import qualified Data.Sequence as Seq
  44 import qualified Data.Text as T
  45 import qualified Data.Time.Clock as Time
  46 import qualified Network.HTTP.Client as Client
  47 import qualified Network.HTTP.Media as Media
  48 import qualified Network.HTTP.Types as HTTP
  49 import qualified Network.URI as URI
  50
  51 import Language.Symantic.HTTP.Media
  52 import Language.Symantic.HTTP.Mime
  53 import Language.Symantic.HTTP.API
  54 import Language.Symantic.HTTP.URI
  55
  56 -- * Type 'Client'
  57 newtype Client a = Client { unClient :: R.ReaderT ClientEnv (E.ExceptT ClientError IO) a }
  58  deriving (Functor, Applicative, Monad)
  59
  60 runClient :: ClientEnv -> Client a -> IO (Either ClientError a)
  61 runClient env (Client c) = E.runExceptT $ R.runReaderT c env
  62
  63 type instance MC.CanDo Client (MC.EffReader ClientEnv)   = 'True
  64 type instance MC.CanDo Client (MC.EffExcept ClientError) = 'True
  65 type instance MC.CanDo Client (MC.EffExec   IO)          = 'True
  66 instance MC.MonadExceptN 'MC.Zero ClientError Client where
  67         throwN px = Client . lift . MC.throwN px
  68 instance MC.MonadReaderN 'MC.Zero ClientEnv Client where
  69         askN px = Client $ MC.askN px
  70 instance MC.MonadExecN 'MC.Zero IO Client where
  71         execN _px = Client . lift . lift
  72
  73 -- ** Type 'ClientEnv'
  74 data ClientEnv = ClientEnv
  75  { clientEnv_manager   :: Client.Manager
  76  , clientEnv_uri       :: URI
  77  , clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
  78  }
  79
  80 -- ** Type 'ClientError'
  81 data ClientError
  82   -- | The server returned an error response
  83   = ClientError_FailureResponse ClientResponse
  84   -- | The body could not be decoded at the expected type
  85   | ClientError_DecodeFailure Text ClientResponse
  86   -- | The content-type of the response is not supported
  87   | ClientError_UnsupportedContentType MediaType ClientResponse
  88   -- | The content-type header is invalid
  89   | ClientError_InvalidContentTypeHeader ClientResponse
  90   -- | There was a connection error, and no response was received
  91   | ClientError_ConnectionError Text
  92   deriving (Eq, Show{-, Generic, Typeable-})
  93 instance Exn.Exception ClientError
  94
  95 -- * Type 'ClientRequest'
  96 data ClientRequest = ClientRequest
  97  { clientReqHttpVersion :: HTTP.HttpVersion
  98  , clientReqMethod      :: HTTP.Method
  99  , clientReqPath        :: BSB.Builder
 100  , clientReqQueryString :: Seq HTTP.QueryItem
 101  , clientReqAccept      :: Seq Media.MediaType
 102  , clientReqHeaders     :: Seq HTTP.Header
 103  , clientReqBody        :: Maybe (Client.RequestBody, Media.MediaType)
 104  }
 105 instance Default ClientRequest where
 106         def = ClientRequest
 107          { clientReqHttpVersion = HTTP.http11
 108          , clientReqMethod      = HTTP.methodGet
 109          , clientReqPath        = ""
 110          , clientReqQueryString = Seq.empty
 111          , clientReqAccept      = Seq.empty
 112          , clientReqHeaders     = Seq.empty
 113          , clientReqBody        = Nothing
 114          }
 115
 116 clientRequest :: URI -> ClientRequest -> Client.Request
 117 clientRequest uri req =
 118         Client.defaultRequest
 119          { Client.method         = clientReqMethod req
 120          , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority uri
 121          , Client.port           = case URI.uriPort <$> URI.uriAuthority uri of
 122                                     Just (':':p) | Just port <- readMaybe p -> port
 123                                     _ -> 0
 124          , Client.path           = BSL.toStrict $ fromString (URI.uriPath uri) <> BSB.toLazyByteString (clientReqPath req)
 125          , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
 126          , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
 127          , Client.requestBody
 128          , Client.secure         = URI.uriScheme uri == "https"
 129          }
 130         where
 131         headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
 132                 toList $ clientReqHeaders req
 133
 134         acceptHeader | null hs   = []
 135                      | otherwise = [("Accept", Media.renderHeader hs)]
 136                 where
 137                 hs = toList $ clientReqAccept req
 138
 139         (requestBody, contentTypeHeader) =
 140                 case clientReqBody req of
 141                  Nothing          -> (Client.RequestBodyLBS "", [])
 142                  Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
 143
 144 -- ** Type 'ClientResponse'
 145 type ClientResponse = ClientResponseF BSL.ByteString
 146 data ClientResponseF a = ClientResponse
 147  { clientResStatus      :: HTTP.Status
 148  , clientResHeaders     :: Seq HTTP.Header
 149  , clientResHttpVersion :: HTTP.HttpVersion
 150  , clientResBody        :: a
 151  } deriving (Eq, Show, Functor)
 152
 153 clientResponse :: Client.Response a -> ClientResponseF a
 154 clientResponse res =
 155         ClientResponse
 156          { clientResStatus      = Client.responseStatus res
 157          , clientResBody        = Client.responseBody res
 158          , clientResHeaders     = Seq.fromList $ Client.responseHeaders res
 159          , clientResHttpVersion = Client.responseVersion res
 160          }
 161
 162 runClientRequest :: ClientRequest -> Client ClientResponse
 163 runClientRequest clientReq = do
 164         ClientEnv{..} <- MC.ask
 165         let req = clientRequest clientEnv_uri clientReq
 166         request <- case clientEnv_cookieJar of
 167                 Nothing -> pure req
 168                 Just cj -> MC.exec $ do
 169                         now <- Time.getCurrentTime
 170                         STM.atomically $ do
 171                                 oldCookieJar <- STM.readTVar cj
 172                                 let (newRequest, newCookieJar) =
 173                                         Client.insertCookiesIntoRequest req oldCookieJar now
 174                                 STM.writeTVar cj newCookieJar
 175                                 pure newRequest
 176         lrRes <- MC.exec $ catchConnectionError $ Client.httpLbs request clientEnv_manager
 177         case lrRes of
 178                 Left err -> MC.throw err
 179                 Right res -> do
 180                         for_ clientEnv_cookieJar $ \cj -> MC.exec $ do
 181                                 now <- Time.getCurrentTime
 182                                 STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res request now)
 183                         let status_code = HTTP.statusCode $ Client.responseStatus res
 184                             ourResponse = clientResponse res
 185                         unless (status_code >= 200 && status_code < 300) $
 186                                 MC.throw $ ClientError_FailureResponse ourResponse
 187                         return ourResponse
 188
 189 catchConnectionError :: IO a -> IO (Either ClientError a)
 190 catchConnectionError action =
 191         Exn.catch (Right <$> action) $ \err ->
 192                 pure . Left . ClientError_ConnectionError .
 193                 T.pack $ show (err :: Client.HttpException)
 194
 195 -- ** Type 'ClientResponseStreaming'
 196 newtype ClientResponseStreaming = ClientResponseStreaming
 197  { runResponseStreaming ::
 198      forall a. (ClientResponseF (IO BS.ByteString) -> IO a) -> IO a }
 199
 200 runClientRequestStreaming :: ClientRequest -> Client ClientResponseStreaming
 201 runClientRequestStreaming clientReq = do
 202         ClientEnv{..} <- MC.ask
 203         let req = clientRequest clientEnv_uri clientReq
 204         return $ ClientResponseStreaming $ \k ->
 205                 Client.withResponse req clientEnv_manager $ \res -> do
 206                         let status_code = HTTP.statusCode $ Client.responseStatus res
 207                         unless (status_code >= 200 && status_code < 300) $ do
 208                                 responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
 209                                 Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
 210                         k $ clientResponse res
 211
 212
 213
 214
 215 getContentType ::
 216  MC.MonadExcept ClientError m =>
 217  ClientResponse -> m MediaType
 218 getContentType clientRes =
 219         case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
 220          Nothing -> return $ "application"Media.//"octet-stream"
 221          Just mt ->
 222                 case Media.parseAccept mt of
 223                  Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
 224                  Just mt' -> return mt'
 225
 226 mimeUnrenderResponse ::
 227  MimeUnrender mt a =>
 228  MC.MonadExcept ClientError m =>
 229  -- RunClient m =>
 230  ClientResponse -> Proxy mt -> m a
 231 mimeUnrenderResponse clientRes mt = do
 232         mtRes <- getContentType clientRes
 233         unless (any (Media.matches mtRes) $ mediaTypes mt) $
 234                 MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 235         case mimeUnrender mt $ clientResBody clientRes of
 236          Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
 237          Right val -> return val