@@ -24,10 +24,14 @@ module Servant.Reflex
2424 ) where
2525
2626import Control.Applicative
27+import qualified Data.Set as Set
28+import qualified Data.Text.Encoding as E
29+import Data.CaseInsensitive (mk)
2730import Data.Proxy
2831import Data.String.Conversions
29−import Data.Text (Text)
30−import qualified Data.Text as T
32+import qualified Data.Map as Map
33+import Data.Text (Text)
34+import qualified Data.Text as T
3135import Data.Text.Encoding
3236import GHC.TypeLits
3337import Servant.API
@@ -120,42 +124,60 @@ instance {-# OVERLAPPING #-}
120124 performRequestNoBody method req baseurl
121125 where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
122126
123−-- -- HEADERS Verb (Content) --
124−-- -- Headers combinator not treated in fully general case,
125−-- -- in order to deny instances for (Headers ls (Capture "id" Int)),
126−-- -- 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),
132−-- MonadWidget t m
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
142−-- }
143−
127+toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
128+toHeaders r =
129+ let toBS = E.encodeUtf8
130+ hdrs = maybe []
131+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
132+ (Map.toList $ _xhrResponse_headers xhr))
133+ (response r)
134+ in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
135+
136+class BuildHeaderKeysTo hs where
137+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
138+
139+instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
140+ where buildHeaderKeysTo _ = []
141+
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)
145+
146+-- HEADERS Verb (Content) --
147+-- Headers combinator not treated in fully general case,
148+-- in order to deny instances for (Headers ls (Capture "id" Int)),
149+-- a combinator that wouldn't make sense
144150-- TODO Overlapping??
145−-- -- HEADERS Verb (No content) --
146−-- instance {-# OVERLAPPABLE #-}
147−-- ( BuildHeadersTo ls, ReflectMethod method,
148−-- MonadWidget t m
149−-- ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
150−-- 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)
153−-- clientWithRoute Proxy req baseurl = do
154−-- let method = reflectMethod (Proxy :: Proxy method)
155−-- hdrs <- performRequestNoBody method req baseurl
156−-- return $ Headers { getResponse = NoContent
157−-- , getHeadersHList = buildHeadersTo hdrs
158−-- }
151+instance {-# OVERLAPPABLE #-}
152+ -- Note [Non-Empty Content Types]
153+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
154+ ReflectMethod method, cts' ~ (ct ': cts),
155+ MonadWidget t m
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)))
165+ }
166+
167+-- HEADERS Verb (No content) --
168+instance {-# OVERLAPPABLE #-}
169+ ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
170+ MonadWidget t m
171+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
172+ type Client t m (Verb method status cts (Headers ls NoContent))
173+ = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))
174+ clientWithRoute Proxy _ req baseurl = do
175+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
176+ resp <- performRequestNoBody method req' baseurl
177+ return $ (fmap . fmap) toHeaders resp
178+ where req' = req {respHeaders =
179+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
180+ }
159181
160182
161183-- HEADER
@@ -227,7 +249,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
227249 => HasClient t m (QueryParam sym a :> sublayout) where
228250
229251 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)
231252 Dynamic t (QParam a) -> Client t m sublayout
232253
233254 -- if mparam = Nothing, we don't add it to the query string