]> Git — Sourcephile - haskell/symantic-http.git/blob - Symantic/HTTP/Client.hs
Rename stuffs and init client testing
[haskell/symantic-http.git] / 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 }