@@ -0,0 +1,200 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+
18+-- #include "overlapping-compat.h"
19+-- | This module provides 'client' which can automatically generate
20+-- querying functions for each endpoint just from the type representing your
21+-- API.
22+module Servant.Reflex.Tuple
23+ ( client
24+ , BuildHeaderKeysTo(..)
25+ , toHeaders
26+ , HasClient(..)
27+ , module Servant.Common.Req
28+ , module Servant.Common.BaseUrl
29+ ) where
30+
31+------------------------------------------------------------------------------
32+import Control.Applicative
33+import Data.CaseInsensitive (mk)
34+import Data.Functor.Identity
35+import qualified Data.Map as Map
36+import Data.Monoid ((<>))
37+import Data.Proxy (Proxy (..))
38+import qualified Data.Set as Set
39+import Data.Text (Text)
40+import qualified Data.Text as T
41+import qualified Data.Text.Encoding as E
42+import GHC.TypeLits (KnownSymbol, symbolVal)
43+import Servant.API ((:<|>) (..), (:>), BasicAuth,
44+ BasicAuthData, BuildHeadersTo (..),
45+ Capture, Header, Headers (..),
46+ HttpVersion, IsSecure, MimeRender (..),
47+ MimeUnrender, NoContent, QueryFlag,
48+ QueryParam, QueryParams, Raw,
49+ ReflectMethod (..), RemoteHost,
50+ ReqBody, ToHttpApiData (..), Vault,
51+ Verb, contentType)
52+
53+import Reflex.Dom (Dynamic, Event, Reflex,
54+ XhrRequest (..), XhrResponse (..),
55+ XhrResponseHeaders (..),
56+ attachPromptlyDynWith, constDyn, ffor,
57+ fmapMaybe, leftmost,
58+ performRequestsAsync)
59+------------------------------------------------------------------------------
60+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
61+ SupportsServantReflex, baseUrlWidget,
62+ showBaseUrl)
63+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
64+ ReqIO, ReqResult (..), addHeaderIO,
65+ authData, defReqIO, evalResponse,
66+ performRequestsCT,
67+ performRequestsNoBody,
68+ performSomeRequestsAsync,
69+ prependToPathPartsIO, qParamToQueryPart,
70+ qParams, reqBody, reqFailure,
71+ reqMethodIO, reqSuccess, reqTag,
72+ respHeadersIO, response)
73+
74+type family ToTuple a :: *
75+
76+type instance ToTuple () = ()
77+type instance ToTuple (a,()) = a
78+type instance ToTuple (a,(b,())) = (a,b)
79+type instance ToTuple (a,(b,(c,()))) = (a,b,c)
80+type instance ToTuple (a,(b,(c,(d,())))) = (a,b,c)
81+type instance ToTuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)
82+
83+client :: (HasClient layout t m, HasInp layout) => Proxy layout -> Proxy m -> BaseUrl -> Client layout t m
84+client = undefined
85+
86+class HasInp layout where
87+ type Inp layout :: *
88+ type Out layout :: *
89+ inpToReq :: Proxy layout -> Inp layout -> ReqIO
90+
91+class HasClient layout (t :: *) (m :: * -> *) where
92+ type Client layout t m :: *
93+
94+instance (HasClient a t m,
95+ HasClient b t m,
96+ HasInp a,
97+ HasInp b
98+ ) => HasClient (a :<|> b) t m where
99+ type Client (a :<|> b) t m = Client a t m :<|> Client b t m
100+
101+instance (ToHttpApiData a, HasInp sublayout) => HasInp (Capture capture a :> sublayout) where
102+ type Inp (Capture capture a :> sublayout) = (a, Inp sublayout)
103+ type Out (Capture capture a :> sublayout) = Out sublayout
104+ inpToReq _ (a, otherInp) = prependToPathPartsIO (toUrlPiece a) $ inpToReq (Proxy :: Proxy sublayout) otherInp
105+
106+instance (HasInp (Capture capture a :> sublayout)) => HasClient (Capture capture a :> sublayout) t m where
107+ type Client (Capture capture a :> sublayout) t m =
108+ Event t (ToTuple (Inp (Capture capture a :> sublayout))) ->
109+ m (Event t (Out (Capture capture a :> sublayout)))
110+
111+
112+
113+instance {-# OVERLAPPABLE #-}
114+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
115+ ) => HasInp (Verb method status cts' a) where
116+ type Inp (Verb method status cts' a) = ()
117+ type Out (Verb method status cts' a) = Either Text a
118+ inpToReq _ _ = defReqIO
119+
120+instance {-# OVERLAPPABLE #-}
121+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
122+ ) => HasClient (Verb method status cts' a) t m where
123+ type Client (Verb method status cts' a) t m = Event t (ToTuple (Inp (Verb method status cts' a))) ->
124+ m (Event t (Out (Verb method status cts' a)))
125+
126+
127+instance {-# OVERLAPPING #-}
128+ (ReflectMethod method) => HasInp (Verb method status cts NoContent) where
129+ type Inp (Verb method status cts NoContent) = ()
130+ type Out (Verb method status cts NoContent) = Either Text NoContent
131+
132+
133+instance {-# OVERLAPPING #-}
134+ (ReflectMethod method, SupportsServantReflex t m)
135+ => HasClient (Verb method status cts NoContent) t m where
136+ type Client (Verb method status cts NoContent) t m =
137+ Event t (ToTuple (Inp (Verb method status cts NoContent))) ->
138+ m (Event t (Out (Verb method status cts NoContent)))
139+
140+
141+instance {-# OVERLAPPABLE #-}
142+ (MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
143+ ReflectMethod method, cts' ~ (ct ': cts)
144+ ) => HasInp (Verb method status cts' (Headers ls a)) where
145+ type Inp (Verb method status cts' (Headers ls a)) = ()
146+ type Out (Verb method status cts' (Headers ls a)) = Either Text (Headers ls a)
147+ inpToReq _ _ = defReqIO { respHeadersIO = OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))}
148+
149+
150+instance {-# OVERLAPPABLE #-}
151+ HasInp (Verb method status cts' (Headers ls a))
152+ => HasClient (Verb method status cts' (Headers ls a)) t m where
153+ type Client (Verb method status cts' (Headers ls a)) t m =
154+ Event t (ToTuple (Inp (Verb method status cts' (Headers ls a)))) ->
155+ m (Event t (Out (Verb method status cts' (Headers ls a))))
156+
157+instance {-# OVERLAPPING #-}
158+ (BuildHeadersTo ls,
159+ BuildHeaderKeysTo ls) => HasInp (Verb method status cts' (Headers ls NoContent)) where
160+ type Inp (Verb method status cts' (Headers ls NoContent)) = ()
161+ type Out (Verb method status cts' (Headers ls NoContent)) = Either Text (Headers ls NoContent)
162+ inpToReq _ _ = defReqIO { respHeadersIO = OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))}
163+
164+instance {-# OVERLAPPING #-}
165+ (BuildHeadersTo ls,
166+ BuildHeaderKeysTo ls,
167+ SupportsServantReflex t m) => HasClient (Verb method status cts' (Headers ls NoContent)) t m where
168+ type Client (Verb method status cts' (Headers ls NoContent)) t m =
169+ Event t (ToTuple (Inp (Verb method status cts' (Headers ls NoContent)))) ->
170+ m (Event t (Out (Verb method status cts' (Headers ls NoContent))))
171+
172+
173+toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
174+toHeaders r =
175+ let toBS = E.encodeUtf8
176+ hdrs = maybe []
177+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
178+ (Map.toList $ _xhrResponse_headers xhr))
179+ (response r)
180+ in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
181+
182+class BuildHeaderKeysTo hs where
183+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
184+
185+instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
186+ where buildHeaderKeysTo _ = []
187+
188+instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
189+ => BuildHeaderKeysTo ((Header h v) ': xs) where
190+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
191+
192+
193+instance (KnownSymbol sym, ToHttpApiData a, HasInp sublayout) => HasInp (Header sym a :> sublayout) where
194+ type Inp (Header sym a :> sublayout) = (Maybe a, Inp sublayout)
195+ type Out (Header sym a :> sublayout) = Out sublayout
196+ inpToReq _ (h, vs) = (addHeaderIO hname h) (inpToReq (Proxy :: Proxy sublayout) vs)
197+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
198+
199+instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout t m) => HasClient (Header sym a :> sublayout) t m where
200+ type Client (Header sym a :> sublayout) t m = Event t (ToTuple (Inp (Header sym a :> sublayout))) -> m (Event t (Out (Header sym a :> sublayout)))