-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
-{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Symantic.HTTP.Client where
+module Symantic.HTTP.Client
+ ( module Symantic.HTTP.Client
+ , module Symantic.HTTP.Client.Connection
+ ) where
-import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..), unless)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Data.Bool
import Data.Default.Class (Default(..))
-import Data.Either (Either(..))
-import Data.Eq (Eq(..))
-import Data.Foldable (null, for_, toList, any)
-import Data.Function (($), (.), on)
-import Data.Functor (Functor, (<$>))
-import Data.Maybe (Maybe(..), maybe)
-import Data.Ord (Ord(..))
+import Data.Function (($), (.), id)
+import Data.Functor ((<$>))
+import Data.Maybe (Maybe(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq)
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.Tuple (fst)
-import System.IO (IO)
-import Text.Read (readMaybe)
-import Text.Show (Show(..))
-import qualified Control.Concurrent.STM as STM
-import qualified Control.Exception as Exn
-import qualified Control.Monad.Classes as MC
-import qualified Control.Monad.Trans.Except as E
-import qualified Control.Monad.Trans.Reader as R
+import GHC.Exts (IsList(..))
import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as BSB
-import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Base64 as BS64
import qualified Data.List as List
+import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
-import qualified Data.Text as T
-import qualified Data.Time.Clock as Time
+import qualified Data.Text.Encoding as Text
import qualified Network.HTTP.Client as Client
-import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
-import qualified Network.URI as URI
+import qualified Web.HttpApiData as Web
-import Symantic.HTTP.Media
-import Symantic.HTTP.Mime
-import Symantic.HTTP.URI
+import Symantic.HTTP.API
+import Symantic.HTTP.MIME
+import Symantic.HTTP.Client.Connection
-- * Type 'Client'
-newtype Client a = Client { unClient :: R.ReaderT ClientEnv (E.ExceptT ClientError IO) a }
- deriving (Functor, Applicative, Monad)
-type instance MC.CanDo Client (MC.EffReader ClientEnv) = 'True
-type instance MC.CanDo Client (MC.EffExcept ClientError) = 'True
-type instance MC.CanDo Client (MC.EffExec IO) = 'True
-instance MC.MonadExceptN 'MC.Zero ClientError Client where
- throwN px = Client . lift . MC.throwN px
-instance MC.MonadReaderN 'MC.Zero ClientEnv Client where
- askN px = Client $ MC.askN px
-instance MC.MonadExecN 'MC.Zero IO Client where
- execN _px = Client . lift . lift
-
--- | Try clients in order, last error is preserved.
-instance Alternative Client where
- empty = MC.throw $ ClientError_EmptyClient
- x <|> y = Client $ do
- env <- MC.ask
- MC.exec (runClient env x) >>= \case
- Right xa -> return xa
- Left _err -> unClient y
-
-client ::
- forall mt a.
- MimeUnserialize mt a =>
- (ClientRequestType mt a -> ClientRequest) -> Client a
-client req = do
- clientRes <- doClientRequest $ req ClientRequestType
- clientResMimeUnserialize (Proxy::Proxy mt) clientRes
-
-runClient :: ClientEnv -> Client a -> IO (Either ClientError a)
-runClient env (Client c) = E.runExceptT $ R.runReaderT c env
-
-runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse)
-runClientRequest env req = runClient env (doClientRequest req)
-
--- ** Type 'ClientRequestType'
-data ClientRequestType mt a = ClientRequestType
-
--- ** Type 'ClientEnv'
-data ClientEnv = ClientEnv
- { clientEnv_manager :: Client.Manager
- , clientEnv_baseURI :: URI
- , clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
+-- | @'Client' a k@ is a recipe to produce a 'ClientRequest'
+-- from arguments 'a' (one per number of alternative routes).
+--
+-- 'Client' is analogous to a printf using a format customized for HTTP routing.
+newtype Client a k
+ = Client
+ { unClient :: (ClientModifier -> k) -> a -- Right Kan extension
}
-clientEnv :: Client.Manager -> URI -> ClientEnv
-clientEnv clientEnv_manager clientEnv_baseURI =
- ClientEnv
- { clientEnv_cookieJar = Nothing
- , ..
- }
-
--- ** Type 'ClientError'
-data ClientError
- -- | The server returned an error response
- = ClientError_FailureResponse ClientResponse
- -- | The body could not be decoded at the expected type
- | ClientError_DecodeFailure Text ClientResponse
- -- | The content-type of the response is not supported
- | ClientError_UnsupportedContentType MediaType ClientResponse
- -- | The content-type header is invalid
- | ClientError_InvalidContentTypeHeader ClientResponse
- -- | There was a connection error, and no response was received
- | ClientError_ConnectionError Client.HttpException
- -- | 'Client' is 'empty'
- | ClientError_EmptyClient
- deriving (Eq, Show{-, Generic, Typeable-})
-instance Exn.Exception ClientError
-instance Eq Client.HttpException where
- (==) = (==) `on` show
-
--- * Type 'ClientRequest'
-data ClientRequest = ClientRequest
- { clientReqHttpVersion :: HTTP.HttpVersion
- , clientReqMethod :: HTTP.Method
- , clientReqPath :: BSB.Builder
- , clientReqQueryString :: Seq HTTP.QueryItem
- , clientReqAccept :: Seq Media.MediaType
- , clientReqHeaders :: Seq HTTP.Header
- , clientReqBody :: Maybe (Client.RequestBody, Media.MediaType)
- }
-instance Default ClientRequest where
- def = ClientRequest
- { clientReqHttpVersion = HTTP.http11
- , clientReqMethod = HTTP.methodGet
- , clientReqPath = ""
- , clientReqQueryString = Seq.empty
- , clientReqAccept = Seq.empty
- , clientReqHeaders = Seq.empty
- , clientReqBody = Nothing
- }
-instance Show ClientRequest where
- show _ = "ClientRequest"
-
-clientRequest :: URI -> ClientRequest -> Client.Request
-clientRequest baseURI req =
- Client.defaultRequest
- { Client.method = clientReqMethod req
- , Client.host = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
- , Client.port = case URI.uriPort <$> URI.uriAuthority baseURI of
- Just (':':p) | Just port <- readMaybe p -> port
- _ -> 0
- , Client.path = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
- , Client.queryString = HTTP.renderQuery True . toList $ clientReqQueryString req
- , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
- , Client.requestBody
- , Client.secure = URI.uriScheme baseURI == "https"
- }
- where
- headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
- toList $ clientReqHeaders req
-
- acceptHeader | null hs = []
- | otherwise = [("Accept", Media.renderHeader hs)]
- where
- hs = toList $ clientReqAccept req
-
- (requestBody, contentTypeHeader) =
- case clientReqBody req of
- Nothing -> (Client.RequestBodyLBS "", [])
- Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
-
-setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
-setClientRequestBodyLBS body mt req = req{ clientReqBody =
- Just (Client.RequestBodyLBS body, mt) }
-
-setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
-setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
-
--- ** Type 'ClientResponse'
-type ClientResponse = ClientResponseWithBody BSL.ByteString
-data ClientResponseWithBody a = ClientResponse
- { clientResStatus :: HTTP.Status
- , clientResHeaders :: Seq HTTP.Header
- , clientResHttpVersion :: HTTP.HttpVersion
- , clientResBody :: a
- } deriving (Eq, Show, Functor)
-
-clientResponse :: Client.Response a -> ClientResponseWithBody a
-clientResponse res =
- ClientResponse
- { clientResStatus = Client.responseStatus res
- , clientResBody = Client.responseBody res
- , clientResHeaders = Seq.fromList $ Client.responseHeaders res
- , clientResHttpVersion = Client.responseVersion res
- }
-
-doClientRequest :: ClientRequest -> Client ClientResponse
-doClientRequest clientReq = do
- ClientEnv{..} <- MC.ask
- req <-
- let req = clientRequest clientEnv_baseURI clientReq in
- case clientEnv_cookieJar of
- Nothing -> pure req
- Just cj ->
- MC.exec $ do
- now <- Time.getCurrentTime
- STM.atomically $ do
- oldCookieJar <- STM.readTVar cj
- let (newRequest, newCookieJar) =
- Client.insertCookiesIntoRequest req oldCookieJar now
- STM.writeTVar cj newCookieJar
- pure newRequest
- lrRes <-
- MC.exec $ catchConnectionError $
- Client.httpLbs req clientEnv_manager
- case lrRes of
- Left err -> MC.throw err
- Right res -> do
- for_ clientEnv_cookieJar $ \cj ->
- MC.exec $ do
- now <- Time.getCurrentTime
- STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
- let status = HTTP.statusCode $ Client.responseStatus res
- clientRes = clientResponse res
- unless (status >= 200 && status < 300) $
- MC.throw $ ClientError_FailureResponse clientRes
- return clientRes
-
-catchConnectionError :: IO a -> IO (Either ClientError a)
-catchConnectionError action =
- Exn.catch (Right <$> action) $ \err ->
- return $ Left $ ClientError_ConnectionError err
-
--- ** Type 'ClientResponseStreaming'
-newtype ClientResponseStreaming = ClientResponseStreaming
- { runResponseStreaming ::
- forall a. (ClientResponseWithBody (IO BS.ByteString) -> IO a) -> IO a }
-
-doClientRequestStreaming :: ClientRequest -> Client ClientResponseStreaming
-doClientRequestStreaming clientReq = do
- ClientEnv{..} <- MC.ask
- let req = clientRequest clientEnv_baseURI clientReq
- return $ ClientResponseStreaming $ \k ->
- Client.withResponse req clientEnv_manager $ \res -> do
- let status = HTTP.statusCode $ Client.responseStatus res
- unless (status >= 200 && status < 300) $ do
- responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
- Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
- k $ clientResponse res
-
-clientResContentType ::
- MC.MonadExcept ClientError m =>
- ClientResponse -> m MediaType
-clientResContentType clientRes =
- case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
- Nothing -> return $ "application"Media.//"octet-stream"
- Just mt ->
- case Media.parseAccept mt of
- Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
- Just mt' -> return mt'
-clientResMimeUnserialize ::
- MimeUnserialize mt a =>
- MC.MonadExcept ClientError m =>
- Proxy mt -> ClientResponse -> m a
-clientResMimeUnserialize mt clientRes = do
- mtRes <- clientResContentType clientRes
- unless (any (Media.matches mtRes) $ mediaTypes mt) $
- MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
- case mimeUnserialize mt $ clientResBody clientRes of
- Left err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
- Right val -> return val
+-- | @'client' api@ returns the 'ClientRequest'
+-- builders from the given 'api'.
+client :: Client api ClientRequest -> api
+client (Client cmd) = cmd ($ def)
+
+-- ** Type 'ClientModifier'
+type ClientModifier = ClientRequest -> ClientRequest
+
+instance Cat Client where
+ Client x <.> Client y = Client $ \k ->
+ x $ \fx -> y $ \fy -> k $ fy . fx
+instance Alt Client where
+ Client x <!> Client y = Client $ \k ->
+ x k :!: y k
+ {-
+ type AltMerge Client = (:!:)
+ Client x <!> Client y = Client $ \k ->
+ x (\cm -> let n:!:_ = k cm in n) :!:
+ y (\cm -> let _:!:n = k cm in n)
+ -}
+ -- try = id -- FIXME: see what to do
+instance Pro Client where
+ dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
+
+instance HTTP_Path Client where
+ type PathConstraint Client a = Web.ToHttpApiData a
+ segment s = Client $ \k -> k $ \req ->
+ req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece s }
+ capture' _n = Client $ \k a -> k $ \req ->
+ req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece a }
+ captureAll = Client $ \k ss -> k $ \req ->
+ req{ clientReqPath =
+ List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
+ Web.toUrlPiece <$> ss
+ }
+instance HTTP_Header Client where
+ header n = Client $ \k v -> k $ \req ->
+ req{ clientReqHeaders = clientReqHeaders req Seq.|> (n, Web.toHeader v) }
+instance HTTP_BasicAuth Client where
+ type BasicAuthArgs Client a k = BasicAuthUser -> BasicAuthPass -> k
+ basicAuth' realm = Client $ \k user pass -> k $ \req ->
+ req{ clientReqHeaders =
+ let user_pass = Text.encodeUtf8 $ user<>":"<>pass in
+ clientReqHeaders req Seq.|>
+ ( HTTP.hAuthorization
+ , Web.toHeader $ "Basic " <> BS64.encode user_pass
+ )
+ }
+instance HTTP_Query Client where
+ type QueryConstraint Client a = Web.ToHttpApiData a
+ queryParams' n = Client $ \k vs -> k $ \req ->
+ req{ clientReqQueryString =
+ clientReqQueryString req <>
+ fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
+instance HTTP_Version Client where
+ version v = Client $ \k -> k $ \req ->
+ req{clientReqHttpVersion = v}
+newtype ClientBodyArg a (ts::[*]) = ClientBodyArg a
+instance HTTP_Body Client where
+ type BodyArg Client = ClientBodyArg
+ type BodyConstraint Client a ts = MimeTypes ts (MimeEncodable a)
+ body' ::
+ forall a ts k repr.
+ BodyConstraint repr a ts =>
+ repr ~ Client =>
+ repr (BodyArg repr a ts -> k) k
+ body'= Client $ \k (ClientBodyArg a) -> k $ \req ->
+ req{clientReqBody =
+ case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable a) of
+ MimeType (mt::Proxy t) ->
+ Just
+ ( Client.RequestBodyLBS $ mimeEncode mt a
+ , mediaType @t )
+ }
+instance HTTP_Response Client where
+ type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
+ type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
+ type Response Client = ClientRequest
+ response ::
+ forall a ts repr.
+ ResponseConstraint repr a ts =>
+ repr ~ Client =>
+ HTTP.Method ->
+ repr (ResponseArgs repr a ts)
+ (Response repr)
+ response m = Client $ \k Proxy Proxy -> k $ \req ->
+ req
+ { clientReqMethod = m
+ , clientReqAccept =
+ clientReqAccept req <>
+ fromList (toList $ mediaTypes @ts @(MimeDecodable a))
+ }
+
+instance Web.ToHttpApiData BS.ByteString where
+ toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
+ toHeader = id
sourcephile / git / haskell / symantic-http.git / blobdiff