Symantic/HTTP/Client.hs

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