Symantic/HTTP/Client.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE StrictData #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Symantic.HTTP.Client
   5  ( module Symantic.HTTP.Client
   6  , module Symantic.HTTP.Client.Connection
   7  ) where
   8
   9 import Data.Default.Class (Default(..))
  10 import Data.Function (($), (.), id)
  11 import Data.Functor ((<$>))
  12 import Data.Maybe (Maybe(..))
  13 import Data.Proxy (Proxy(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import GHC.Exts (IsList(..))
  16 import qualified Data.ByteString as BS
  17 import qualified Data.ByteString.Base64 as BS64
  18 import qualified Data.List as List
  19 import qualified Data.List.NonEmpty as NonEmpty
  20 import qualified Data.Sequence as Seq
  21 import qualified Data.Text.Encoding as Text
  22 import qualified Network.HTTP.Client as Client
  23 import qualified Network.HTTP.Types as HTTP
  24 import qualified Web.HttpApiData as Web
  25
  26 import Symantic.HTTP.API
  27 import Symantic.HTTP.MIME
  28 import Symantic.HTTP.Client.Connection
  29
  30 -- * Type 'Client'
  31 -- | @'Client' a k@ is a recipe to produce a 'ClientRequest'
  32 -- from arguments 'a' (one per number of alternative routes).
  33 --
  34 -- 'Client' is analogous to a printf using a format customized for HTTP routing.
  35 newtype Client a k
  36  =      Client
  37  {    unClient :: (ClientModifier -> k) -> a -- Right Kan extension
  38  }
  39
  40 -- | @'client' api@ returns the 'ClientRequest'
  41 -- builders from the given 'api'.
  42 client :: Client api ClientRequest -> api
  43 client (Client cmd) = cmd ($ def)
  44
  45 -- ** Type 'ClientModifier'
  46 type ClientModifier = ClientRequest -> ClientRequest
  47
  48 instance Cat Client where
  49         Client x <.> Client y = Client $ \k ->
  50                 x $ \fx -> y $ \fy -> k $ fy . fx
  51 instance Alt Client where
  52         Client x <!> Client y = Client $ \k ->
  53                 x k :!: y k
  54         {-
  55         type AltMerge Client = (:!:)
  56         Client x <!> Client y = Client $ \k ->
  57                 x (\cm -> let n:!:_ = k cm in n) :!:
  58                 y (\cm -> let _:!:n = k cm in n)
  59         -}
  60         -- try = id -- FIXME: see what to do
  61 instance Pro Client where
  62         dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
  63
  64 instance HTTP_Path Client where
  65         type PathConstraint Client a = Web.ToHttpApiData a
  66         segment s = Client $ \k -> k $ \req ->
  67                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece s }
  68         capture' _n = Client $ \k a -> k $ \req ->
  69                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece a }
  70         captureAll = Client $ \k ss -> k $ \req ->
  71                 req{ clientReqPath =
  72                         List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
  73                         Web.toUrlPiece <$> ss
  74                  }
  75 instance HTTP_Header Client where
  76         header n = Client $ \k v -> k $ \req ->
  77                 req{ clientReqHeaders = clientReqHeaders req Seq.|> (n, Web.toHeader v) }
  78 instance HTTP_BasicAuth Client where
  79         type BasicAuthArgs Client a k = BasicAuthUser -> BasicAuthPass -> k
  80         basicAuth' realm = Client $ \k user pass -> k $ \req ->
  81                 req{ clientReqHeaders =
  82                         let user_pass = Text.encodeUtf8 $ user<>":"<>pass in
  83                         clientReqHeaders req Seq.|>
  84                          ( HTTP.hAuthorization
  85                          , Web.toHeader $ "Basic " <> BS64.encode user_pass
  86                          )
  87                  }
  88 instance HTTP_Query Client where
  89         type QueryConstraint Client a = Web.ToHttpApiData a
  90         queryParams' n = Client $ \k vs -> k $ \req ->
  91                 req{ clientReqQueryString =
  92                         clientReqQueryString req <>
  93                         fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
  94 instance HTTP_Version Client where
  95         version v = Client $ \k -> k $ \req ->
  96                 req{clientReqHttpVersion = v}
  97 newtype ClientBodyArg a (ts::[*]) = ClientBodyArg a
  98 instance HTTP_Body Client where
  99         type BodyArg Client = ClientBodyArg
 100         type BodyConstraint Client a ts = MimeTypes ts (MimeEncodable a)
 101         body' ::
 102          forall a ts k repr.
 103          BodyConstraint repr a ts =>
 104          repr ~ Client =>
 105          repr (BodyArg repr a ts -> k) k
 106         body'= Client $ \k (ClientBodyArg a) -> k $ \req ->
 107                 req{clientReqBody =
 108                         case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable a) of
 109                          MimeType (mt::Proxy t) ->
 110                                 Just
 111                                  ( Client.RequestBodyLBS $ mimeEncode mt a
 112                                  , mediaType @t )
 113                  }
 114 instance HTTP_Response Client where
 115         type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
 116         type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
 117         type Response Client = ClientRequest
 118         response ::
 119          forall a ts repr.
 120          ResponseConstraint repr a ts =>
 121          repr ~ Client =>
 122          HTTP.Method ->
 123          repr (ResponseArgs repr a ts)
 124               (Response repr)
 125         response m = Client $ \k Proxy Proxy -> k $ \req ->
 126                 req
 127                  { clientReqMethod = m
 128                  , clientReqAccept =
 129                         clientReqAccept req <>
 130                         fromList (toList $ mediaTypes @ts @(MimeDecodable a))
 131                  }
 132
 133 instance Web.ToHttpApiData BS.ByteString where
 134         toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
 135         toHeader = id