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 instance Cat Client where
  46         Client x <.> Client y = Client $ \k ->
  47                 x $ \fx -> y $ \fy -> k $ fy . fx
  48 instance Alt Client where
  49         Client x <!> Client y = Client $ \k ->
  50                 x k :!: y k
  51         {-
  52         type AltMerge Client = (:!:)
  53         Client x <!> Client y = Client $ \k ->
  54                 x (\cm -> let n:!:_ = k cm in n) :!:
  55                 y (\cm -> let _:!:n = k cm in n)
  56         -}
  57         -- try = id -- FIXME: see what to do
  58 instance Pro Client where
  59         dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
  60
  61 instance HTTP_Path Client where
  62         segment s = Client $ \k -> k $ \req ->
  63                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece s }
  64         capture' _n = Client $ \k a -> k $ \req ->
  65                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece a }
  66         captureAll = Client $ \k ss -> k $ \req ->
  67                 req{ clientReqPath =
  68                         List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
  69                         Web.toUrlPiece <$> ss
  70                  }
  71 instance HTTP_Header Client where
  72         header n = Client $ \k v -> k $ \req ->
  73                 req{ clientReqHeaders = clientReqHeaders req Seq.|> (n, Web.toHeader v) }
  74 instance Web.ToHttpApiData HeaderValue where
  75         toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
  76         toHeader = id
  77 instance HTTP_Query Client where
  78         queryParams' n = Client $ \k vs -> k $ \req ->
  79                 req{ clientReqQueryString =
  80                         clientReqQueryString req <>
  81                         fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
  82         queryFlag n = Client $ \k b -> k $ \req ->
  83                 if b
  84                 then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
  85                 else req
  86 instance HTTP_Version Client where
  87         version v = Client $ \k -> k $ \req ->
  88                 req{clientReqHttpVersion = v}
  89 instance HTTP_Response Client where
  90         type Response    Client = ClientRequest
  91         type ResponseArg Client = ClientRequestType
  92         response ::
  93          forall repr k a mt.
  94          MimeSerialize a mt =>
  95          MimeUnserialize a mt =>
  96          k ~ Response repr =>
  97          repr ~ Client =>
  98          HTTP.Method ->
  99          repr (ResponseArg repr mt a -> k) k
 100         response m = Client $ \k ClientRequestType -> k $ \req ->
 101                 req
 102                  { clientReqMethod = m
 103                  , clientReqAccept = clientReqAccept req Seq.|> mimeType (Proxy::Proxy mt)
 104                  }