@@ -24,10 +24,14 @@ module Servant.Reflex
26import Control.Applicative
26import Control.Applicative
27+import qualified Data.Set as Set
28+import qualified Data.Text.Encoding as E
29+import Data.CaseInsensitive (mk)
27import Data.Proxy
30import Data.Proxy
28import Data.String.Conversions
31import Data.String.Conversions
32+import qualified Data.Map as Map
29−import Data.Text (Text)
33+import Data.Text (Text)
30−import qualified Data.Text as T
34+import qualified Data.Text as T
31import Data.Text.Encoding
35import Data.Text.Encoding
32import GHC.TypeLits
36import GHC.TypeLits
33import Servant.API
37import Servant.API
@@ -120,42 +124,60 @@ instance {-# OVERLAPPING #-}
120 performRequestNoBody method req baseurl
124 performRequestNoBody method req baseurl
121 where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
125 where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
127+toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
129+ let toBS = E.encodeUtf8
131+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
132+ (Map.toList $ _xhrResponse_headers xhr))
134+ in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
136+class BuildHeaderKeysTo hs where
137+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
139+instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
140+ where buildHeaderKeysTo _ = []
142+instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
143+ => BuildHeaderKeysTo '[(Header h v) ': xs] where
144+ buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
123−-- -- HEADERS Verb (Content) --
146+-- HEADERS Verb (Content) --
124−-- -- Headers combinator not treated in fully general case,
147+-- Headers combinator not treated in fully general case,
125−-- -- in order to deny instances for (Headers ls (Capture "id" Int)),
148+-- in order to deny instances for (Headers ls (Capture "id" Int)),
126−-- -- a combinator that wouldn't make sense
149+-- a combinator that wouldn't make sense
127−-- -- TODO Overlapping??
128−-- instance {-# OVERLAPPABLE #-}
129−-- -- Note [Non-Empty Content Types]
130−-- ( MimeUnrender ct a, BuildHeadersTo ls,
131−-- ReflectMethod method, cts' ~ (ct ': cts),
133−-- ) => HasClient t m (Verb method status cts' (Headers ls a)) where
134−-- type Client t m (Verb method status cts' (Headers ls a))
135−-- = Event t () -> m (Event t (Maybe a, XhrResponse))
136−-- -- ExceptT ServantError IO (Headers ls a)
137−-- clientWithRoute Proxy req baseurl = do
138−-- let method = reflectMethod (Proxy :: Proxy method)
139−-- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl
140−-- return $ Headers { getResponse = resp
141−-- , getHeadersHList = buildHeadersTo hdrs
144-- TODO Overlapping??
150-- TODO Overlapping??
151+instance {-# OVERLAPPABLE #-}
152+ -- Note [Non-Empty Content Types]
153+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
154+ ReflectMethod method, cts' ~ (ct ': cts),
156+ ) => HasClient t m (Verb method status cts' (Headers ls a)) where
157+ type Client t m (Verb method status cts' (Headers ls a)) =
158+ Event t () -> m (Event t (ReqResult (Headers ls a)))
159+ clientWithRoute Proxy _ req baseurl = do
160+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
161+ resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl
162+ return $ (fmap . fmap) toHeaders resp
163+ where req' = req { respHeaders =
164+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
145−-- -- HEADERS Verb (No content) --
167+-- HEADERS Verb (No content) --
146−-- instance {-# OVERLAPPABLE #-}
168+instance {-# OVERLAPPABLE #-}
147−-- ( BuildHeadersTo ls, ReflectMethod method,
169+ ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
148−-- MonadWidget t m
170+ MonadWidget t m
149−-- ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
171+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
150−-- type Client t m (Verb method status cts (Headers ls NoContent))
172+ type Client t m (Verb method status cts (Headers ls NoContent))
151−-- = Event t () -> m (Event t XhrResponse)
152−-- -- ExceptT ServantError IO (Headers ls NoContent)
173+ = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))
153−-- clientWithRoute Proxy req baseurl = do
174+ clientWithRoute Proxy _ req baseurl = do
154−-- let method = reflectMethod (Proxy :: Proxy method)
175+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
155−-- hdrs <- performRequestNoBody method req baseurl
176+ resp <- performRequestNoBody method req' baseurl
156−-- return $ Headers { getResponse = NoContent
177+ return $ (fmap . fmap) toHeaders resp
157−-- , getHeadersHList = buildHeadersTo hdrs
178+ where req' = req {respHeaders =
179+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
@@ -227,7 +249,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
227 => HasClient t m (QueryParam sym a :> sublayout) where
249 => HasClient t m (QueryParam sym a :> sublayout) where
229 type Client t m (QueryParam sym a :> sublayout) =
251 type Client t m (QueryParam sym a :> sublayout) =
230− -- TODO (Maybe a), or (Maybe (Maybe a))? (should the user be able to send a Nothing)
231 Dynamic t (QParam a) -> Client t m sublayout
252 Dynamic t (QParam a) -> Client t m sublayout
233 -- if mparam = Nothing, we don't add it to the query string
254 -- if mparam = Nothing, we don't add it to the query string