Symantic/HTTP/Client.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Symantic.HTTP.Client
   7  ( module Symantic.HTTP.Client
   8  , module Symantic.HTTP.Client.Monad
   9  ) where
  10
  11 import Data.Default.Class (Default(..))
  12 import Data.Function (($), (.), id)
  13 import Data.Functor ((<$>))
  14 import Data.Maybe (Maybe(..))
  15 import Data.Proxy (Proxy(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import GHC.Exts (IsList(..))
  18 import qualified Data.List as List
  19 import qualified Data.Sequence as Seq
  20 import qualified Data.Text.Encoding as Text
  21 import qualified Network.HTTP.Types as HTTP
  22 import qualified Web.HttpApiData as Web
  23
  24 import Symantic.HTTP.API
  25 import Symantic.HTTP.Mime
  26 import Symantic.HTTP.Client.Monad
  27
  28 -- * Type 'Client'
  29 -- | 'Client a k' is a recipe to produce a 'ClientRequest'
  30 -- from arguments 'a' (one per number of alternative routes).
  31 --
  32 -- 'Client' is analogous to a printf using a format customized for HTTP routing.
  33 newtype Client a k = Client { unClient ::
  34         (ClientModifier -> k) -> a -- Right Kan extension
  35  }
  36
  37 -- | @'client' api@ returns the 'ClientRequest's
  38 -- builders from the given 'api'.
  39 client :: Client api ClientRequest -> api
  40 client (Client cmd) = cmd ($ def)
  41
  42 -- ** Type 'ClientModifier'
  43 type ClientModifier = ClientRequest -> ClientRequest
  44
  45 type instance HttpApiData Client = Web.ToHttpApiData
  46 instance Cat Client where
  47         Client x <.> Client y = Client $ \k ->
  48                 x $ \fx -> y $ \fy -> k $ fy . fx
  49 instance Alt Client where
  50         Client x <!> Client y = Client $ \k ->
  51                 x k :!: y k
  52         {-
  53         type AltMerge Client = (:!:)
  54         Client x <!> Client y = Client $ \k ->
  55                 x (\cm -> let n:!:_ = k cm in n) :!:
  56                 y (\cm -> let _:!:n = k cm in n)
  57         -}
  58         -- try = id -- FIXME: see what to do
  59 instance Pro Client where
  60         dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
  61
  62 instance HTTP_Path Client where
  63         segment s = Client $ \k -> k $ \req ->
  64                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece s }
  65         capture' _n = Client $ \k a -> k $ \req ->
  66                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece a }
  67         captureAll = Client $ \k ss -> k $ \req ->
  68                 req{ clientReqPath =
  69                         List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
  70                         Web.toUrlPiece <$> ss
  71                  }
  72 instance HTTP_Header Client where
  73         header n = Client $ \k v -> k $ \req ->
  74                 req{ clientReqHeaders = clientReqHeaders req Seq.|> (n, Web.toHeader v) }
  75 instance Web.ToHttpApiData HeaderValue where
  76         toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
  77         toHeader = id
  78 instance HTTP_Query Client where
  79         queryParams' n = Client $ \k vs -> k $ \req ->
  80                 req{ clientReqQueryString =
  81                         clientReqQueryString req <>
  82                         fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
  83         queryFlag n = Client $ \k b -> k $ \req ->
  84                 if b
  85                 then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
  86                 else req
  87 instance HTTP_Version Client where
  88         version v = Client $ \k -> k $ \req ->
  89                 req{clientReqHttpVersion = v}
  90 instance HTTP_Response Client where
  91         type Response    Client = ClientRequest
  92         type ResponseArg Client = ClientRequestType
  93         response ::
  94          forall repr k a mt.
  95          MimeSerialize a mt =>
  96          MimeUnserialize a mt =>
  97          k ~ Response repr =>
  98          repr ~ Client =>
  99          HTTP.Method ->
 100          repr (ResponseArg repr mt a -> k) k
 101         response m = Client $ \k ClientRequestType -> k $ \req ->
 102                 req
 103                  { clientReqMethod = m
 104                  , clientReqAccept = clientReqAccept req Seq.|> mimeType (Proxy::Proxy mt)
 105                  }