git.iko.soy/typeable/servant-reflex
on master help sign in
Flesh out tuple api instances
fa2a523Greg Hale
exec/API.hs+3−1
compare with master
unifiedsplit
@@ -40,7 +40,9 @@ type API = "getunit" :> Get '[JSON] ()
40 :> Post '[JSON] Double
40 :> Post '[JSON] Double
41 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
42 :<|> "qna" :> ReqBody '[JSON] Question
42 :<|> "qna" :> ReqBody '[JSON] Question
43+ :> Header "qnum" Int
44+ :> Header "is-favorite" Bool
43− :> Post '[JSON] Answer
45+ :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)
44 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
46 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
45 :<|> Raw
47 :<|> Raw
46
48
exec/Example.hs+124−30
@@ -45,15 +45,72 @@ type MyAPI =
45 :> Post '[JSON] Double
45 :> Post '[JSON] Double
46 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
46 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
47 :<|> "qna" :> ReqBody '[JSON] Question
47 :<|> "qna" :> ReqBody '[JSON] Question
48+ :> Header "qnum" Int
49+ :> Header "is-favorite" Bool
48− :> Post '[JSON] Answer
50+ :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)
49 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
51 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
50
52
51main :: IO ()
53main :: IO ()
52main = mainWidget $ do
54main = mainWidget $ do
53− divClass "example-base" runTuple
55+ divClass "example-tuple" runTuple
54 divClass "example-base" run
56 divClass "example-base" run
55 divClass "example-multi" runMulti
57 divClass "example-multi" runMulti
56
58
59+hiWidget :: (SupportsServantReflex t m,
60+ DomBuilder t m,
61+ DomBuilderSpace m ~ GhcjsDomSpace,
62+ PostBuild t m) => m (Dynamic t (Maybe Text),
63+ Dynamic t [Text],
64+ Dynamic t Bool,
65+ Event t ())
66+hiWidget = do
67+ text "Name"
68+ el "br" $ return ()
69+ inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
70+ let checkedName = fmap (\i -> bool (Just i) Nothing (T.null i)) inp
71+ el "br" $ return ()
72+
73+ text "Greetings (space-separated)"
74+ el "br" $ return ()
75+ greetings <- fmap (fmap T.words . value) $
76+ divClass "greetings-input" $ (textInput def)
77+
78+ el "br" $ return ()
79+
80+ gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
81+
82+ el "br" $ return ()
83+ sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
84+ return (checkedName, greetings, gusto, sayHiClicks)
85+
86+
87+readWidget :: (SupportsServantReflex t m,
88+ DomBuilder t m,
89+ DomBuilderSpace m ~ GhcjsDomSpace,
90+ PostBuild t m,
91+ Read a
92+ ) => m (Dynamic t (Maybe a))
93+readWidget = fmap (readMaybe . T.unpack) . value <$> textInput def
94+
95+readWidget' :: (SupportsServantReflex t m,
96+ DomBuilder t m,
97+ DomBuilderSpace m ~ GhcjsDomSpace,
98+ PostBuild t m,
99+ Read a
100+ ) => a -> m (Dynamic t a)
101+readWidget' d = fmap (fromMaybe d . readMaybe . T.unpack) . value <$> textInput def
102+
103+basicAuthWidget :: (SupportsServantReflex t m,
104+ DomBuilder t m,
105+ DomBuilderSpace m ~ GhcjsDomSpace,
106+ PostBuild t m
107+ ) => m (Dynamic t BasicAuthData)
108+basicAuthWidget = do
109+ un <- fmap value $ text "Username" >> textArea def
110+ pw <- fmap value $ text "Unhidden PW" >> textArea def
111+ return $ BasicAuthData <$> fmap T.encodeUtf8 un <*> fmap T.encodeUtf8 pw
112+
113+
57runTuple :: forall t m. (SupportsServantReflex t m,
114runTuple :: forall t m. (SupportsServantReflex t m,
58 DomBuilder t m,
115 DomBuilder t m,
59 DomBuilderSpace m ~ GhcjsDomSpace,
116 DomBuilderSpace m ~ GhcjsDomSpace,
@@ -61,24 +118,60 @@ runTuple :: forall t m. (SupportsServantReflex t m,
61 PostBuild t m,
118 PostBuild t m,
62 MonadHold t m) => m ()
119 MonadHold t m) => m ()
63runTuple = do
120runTuple = do
64− -- el "h1" (text "Tuple API")
121+ el "h1" (text "Tuple API")
65 url <- baseUrlWidget
122 url <- baseUrlWidget
66− -- let (getUnit :<|> getInt :<|> dblint :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
67− -- SR.clientR (Proxy @(SR.Seal API)) (Proxy :: Proxy m) (Proxy :: Proxy t) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
68
123
69− -- let (getUnit :<|> getInt :<|> dblint :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _) =
124+ let (getUnit :<|> getInt :<|> dblInt :<|> sayHi :<|> dbl :<|> ab :<|> question :<|> secret :<|> _) =
70− let (r1 :<|> r2 :<|> r3 :<|> r4 :<|> r5 :<|> r6 :<|> r7 :<|> r8) =
71− SR.clientR (Proxy @MyAPI) (Proxy @m) (Proxy @t) (Proxy @[]) (Proxy @Int) url
125+ SR.clientR (Proxy @API) (Proxy @m) (Proxy @t) (Proxy @[]) url
126+
127+ u <- divClass "demo-group" $ do
128+ unitBtn <- button "get unit"
129+ getUnit (fmap (:[]) unitBtn)
130+
131+ (giR, diR) <- divClass "demo-group" $ do
132+ int <- readWidget
133+ getIntBtn <- button "get int"
134+ dblIntBtn <- button "double int"
135+ gi <- getInt (fmap (:[]) getIntBtn)
136+ di <- dblInt (fmap (:[]) (fmapMaybe id $ tagPromptlyDyn int dblIntBtn))
137+ return (gi, di)
138+
139+ hiResp <- divClass "demo-group" $ do
140+ (nm, greets, gusto, hiClicks) <- hiWidget
141+ let hiReqs = tagPromptlyDyn ((,,) <$> nm <*> greets <*> gusto) hiClicks
142+ sayHi (fmap (:[]) hiReqs)
143+
144+ dblResp <- divClass "demo-group" $ do
145+ dblInput <- readWidget
146+ dblBtn <- button "double double"
147+ dbl $ (fmap (:[])) $ fmapMaybe id $ tagPromptlyDyn dblInput dblBtn
148+
149+ twoPathResp <- divClass "demo-group" $ do
150+ twoPathInp <- text "Two Path" >> checkbox False def
151+ ab (fmap (:[]) $ updated (value twoPathInp))
152+
153+ qnaR <- divClass "demo-group" $ do
154+ q <- fmap Question . value <$> textInput def
155+ i <- readWidget' 0
156+ f <- readWidget' False
157+ question (fmap (:[]) (updated $ (,,) <$> q <*> i <*> f))
158+
159+ secretR <- divClass "demo-group" $ do
160+ ba <- basicAuthWidget
161+ sBtn <- button "Get secret"
162+ secret (fmap pure $ tagPromptlyDyn ba sBtn)
72
163
73− -- let (getUnit :<|> getInt :<|> dblint :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _) =
164+ divClass "demo-group" $ do
74− -- SR.clientR (Proxy @(API)) (Proxy :: Proxy m) (Proxy :: Proxy t) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
165+ el "div" $ text "responses"
75−
166+ dynText =<< holdDyn "No responses yet"
76− -- unitBtn <- button "get unit"
167+ (leftmost [ tshow <$> u , tshow <$> giR
77− -- intBtn <- button "get int"
168+ , tshow <$> diR
78− inp <- fmap (readMaybe @Int . T.unpack) . value <$> textInput def
169+ , tshow <$> hiResp , tshow <$> dblResp
170+ , tshow <$> twoPathResp
171+ , T.concat . fmap (either tshow (\x -> tshow (tshow (getHeaders x), tshow (getResponse x)))) <$> qnaR
172+ , tshow <$> secretR
173+ ])
79
174
80− rs <- r3 (fmap (:[]) (fmapMaybe id $ updated inp))
81− -- display =<< holdDyn "Waiting" (T.pack . show <$> rs)
82 return ()
175 return ()
83
176
84
177
@@ -205,7 +298,7 @@ run = mdo
205 holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
298 holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
206 el "br" (return ())
299 el "br" (return ())
207 divClass "double-result" $ el "p" $ dynText =<<
300 divClass "double-result" $ el "p" $ dynText =<<
208− holdDyn "No number yet" (fmap tShow $
301+ holdDyn "No number yet" (fmap tshow $
209 fmapMaybe reqSuccess (dblResp))
302 fmapMaybe reqSuccess (dblResp))
210 return dblBtn
303 return dblBtn
211
304
@@ -214,7 +307,7 @@ run = mdo
214 b <- value <$> checkbox False def
307 b <- value <$> checkbox False def
215 mpGo <- button "Test"
308 mpGo <- button "Test"
216 multiResp <- multi b (tag (current reqCount) mpGo)
309 multiResp <- multi b (tag (current reqCount) mpGo)
217− dynText =<< holdDyn "No res yet" (fmap tShow $
310+ dynText =<< holdDyn "No res yet" (fmap tshow $
218 fmapMaybe reqSuccess $
311 fmapMaybe reqSuccess $
219 (multiResp))
312 (multiResp))
220 return mpGo
313 return mpGo
@@ -228,14 +321,15 @@ run = mdo
228 txt <- value <$> textInput def
321 txt <- value <$> textInput def
229 ev <- fmap (1 <$) $ button "Question"
322 ev <- fmap (1 <$) $ button "Question"
230 let dQ = Right . Question <$> traceDyn "will send: " txt
323 let dQ = Right . Question <$> traceDyn "will send: " txt
231− rr <- qna dQ ev
324+ -- rr <- qna dQ ev _ _
232 el "p" $
325 el "p" $
326+ return ()
233− dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
327+ -- dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
234
328
235 divClass "demo-group" $ do
329 divClass "demo-group" $ do
236 un <- fmap value $ text "Username" >> textArea def
330 un <- fmap value $ text "Username" >> textArea def
237 pw <- fmap value $ text "Unhidden PW" >> textArea def
331 pw <- fmap value $ text "Unhidden PW" >> textArea def
238− let ba :: Dynamic t (BasicAuthData ) = BasicAuthData
332+ let ba :: Dynamic t BasicAuthData = BasicAuthData
239 <$> fmap T.encodeUtf8 un
333 <$> fmap T.encodeUtf8 un
240 <*> fmap T.encodeUtf8 pw
334 <*> fmap T.encodeUtf8 pw
241 b <- button "Get secret"
335 b <- button "Get secret"
@@ -246,20 +340,20 @@ run = mdo
246
340
247showXhrResponse :: XhrResponse -> Text
341showXhrResponse :: XhrResponse -> Text
248showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
342showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
249− T.unlines ["stat: " <> tShow stat
343+ T.unlines ["stat: " <> tshow stat
250− ,"stattxt: " <> tShow stattxt
344+ ,"stattxt: " <> tshow stattxt
251 ,"resp: " <> maybe "" showRB rbmay
345 ,"resp: " <> maybe "" showRB rbmay
252− ,"rtext: " <> tShow rtmay
346+ ,"rtext: " <> tshow rtmay
253− ,"rHeaders: " <> tShow respHeaders]
347+ ,"rHeaders: " <> tshow respHeaders]
254
348
255−tShow :: Show a => a -> Text
349+tshow :: Show a => a -> Text
256−tShow = T.pack . show
350+tshow = T.pack . show
257
351
258showRB :: XhrResponseBody -> Text
352showRB :: XhrResponseBody -> Text
259−showRB (XhrResponseBody_Default t) = tShow t
353+showRB (XhrResponseBody_Default t) = tshow t
260−showRB (XhrResponseBody_Text t) = tShow t
354+showRB (XhrResponseBody_Text t) = tshow t
261showRB (XhrResponseBody_Blob t) = "<Blob>"
355showRB (XhrResponseBody_Blob t) = "<Blob>"
262−showRB (XhrResponseBody_ArrayBuffer t) = tShow t
356+showRB (XhrResponseBody_ArrayBuffer t) = tshow t
263
357
264note :: e -> Maybe a -> Either e a
358note :: e -> Maybe a -> Either e a
265note e = maybe (Left e) Right
359note e = maybe (Left e) Right
src/Servant/Reflex/RequestAPI.hs+338−161
@@ -19,12 +19,16 @@
19
19
20module Servant.Reflex.RequestAPI where
20module Servant.Reflex.RequestAPI where
21
21
22+import Control.Arrow (first, second)
22import Control.Lens
23import Control.Lens
23import Data.Generics.Product
24import Data.Generics.Product
24import Data.Proxy
25import Data.Proxy
26+import Data.CaseInsensitive (mk)
27+import qualified Data.List as L
25import qualified Data.Map as M
28import qualified Data.Map as M
26import Data.Maybe (catMaybes)
29import Data.Maybe (catMaybes)
27import Data.Semigroup ((<>))
30import Data.Semigroup ((<>))
31+import qualified Data.Set as Set
28import qualified Data.Text.Encoding as E
32import qualified Data.Text.Encoding as E
29import Data.Text (Text)
33import Data.Text (Text)
30import qualified Data.Text as T
34import qualified Data.Text as T
@@ -39,23 +43,61 @@ import Servant.Common.BaseUrl
39
43
40import Reflex.Dom hiding (HList(..))
44import Reflex.Dom hiding (HList(..))
41
45
46+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
47+
48+{-
49+TODO:
50+ - [x] :<|>
51+ - [x] Verb content
52+ - [x] Verb nocontent
53+ - [x] Verb (Headers content)
54+ - [x] Verb (Headers nocontent)
55+ - [ ] Stream
56+ - [X] Capture :> ...
57+ - [ ] Capture' :> ...
58+ - [x] CaptureAll :> ...
59+ - [x] QueryParam :> ...
60+ - [x] QueryParams :> ...
61+ - [x] QueryFlag :> ...
62+ - [x] ReqBody :> ...
63+ - [ ] Header' :> ...
64+ - [x] Header :> ...
65+ - [x] Summary :> ...
66+ - [x] Description :> ...
67+ - [x] path :> ...
68+ - [ ] RemoteHost :> ...
69+ - [x] IsSecure :> ...
70+ - [x] Vault :> ...
71+ - [ ] WithNamedContext :> ...
72+ - [ ] AuthenticatedRequest :> ...
73+ - [x] BasicAuth :> ...
74+ - [ ] EmptyClient :> ...
75+ - [ ] EmptyClient
76+ - [ ] HttpVersion :> ...
77+-}
42data HList xs where
78data HList xs where
43 HNil :: HList '[]
79 HNil :: HList '[]
44 HCons :: x -> HList xs -> HList (x ': xs)
80 HCons :: x -> HList xs -> HList (x ': xs)
45
81
46−clientR :: forall t m layout f tag. (HasClientR t m (Seal layout) f tag, Applicative f, Reflex t)
82+clientR :: forall t m layout f . (HasClientR t m (Seal layout) f, Applicative f, Reflex t)
47− => Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f -> Proxy tag
83+ => Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f
48− -> Dynamic t BaseUrl -> ClientR t m (Seal layout) f tag
84+ -> Dynamic t BaseUrl -> ClientR t m (Seal layout) f
49−clientR _ mP tP fP tagP url =
85+clientR _ mP tP fP url =
50− clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP tagP undefined url undefined
86+ clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP undefined url undefined
51
87
52-- | A class for generating top-level the API client function
88-- | A class for generating top-level the API client function
53−class HasClientR t (m :: * -> *) api (f :: * -> *) tag where
89+class HasClientR t (m :: * -> *) api (f :: * -> *) where
54− type ClientR t m api f tag :: *
90+ type ClientR t m api f :: *
55− clientRWithRoute :: Proxy api -> Proxy m -> Proxy f -> Proxy tag
91+ clientRWithRoute :: Proxy api -> Proxy m -> Proxy f
56 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
92 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
57− -> ClientOptions -> ClientR t m api f tag
93+ -> ClientOptions -> ClientR t m api f
58
94
95+-- instance EndpointR t m Raw f where
96+-- type EInputs t m Raw f = '[XhrRequest T.Text]
97+-- type EOutput t m Raw f = XhrResponse
98+
99+-- mkReq (HCons (XhrRequest method url conf) NHil) =
100+-- ReqR method
59
101
60
102
61-- | A class for generating endpoint-level API client functions
103-- | A class for generating endpoint-level API client functions
@@ -68,42 +110,34 @@ class HasClientR t (m :: * -> *) api (f :: * -> *) tag where
68-- sequences of @:<|>@ combinators, such a listing doesn't make
110-- sequences of @:<|>@ combinators, such a listing doesn't make
69-- sense. So, we use one class for endpoint-level recursion and
111-- sense. So, we use one class for endpoint-level recursion and
70-- another for collecting endpoints into the top-level API
112-- another for collecting endpoints into the top-level API
71−class EndpointR t m api f tag where
113+class EndpointR t m api f where
72−
73− type EndpointResult t m api f tag :: *
74− type EInputs t m api f tag :: [*]
75− type EOutput t m api f tag :: *
76
114
77− mkReq :: HList (EInputs t m api f tag) -> ReqR
115+ type EInputs t m api f :: [*]
78− getResp :: XhrResponse -> EOutput t m api f tag
116+ type EOutput t m api f :: *
79
117
80− eInputs :: HList (EInputs t m api f tag)
118+ mkReq :: HList (EInputs t m api f) -> ReqR
81− clientEndpoint :: Proxy api -> Proxy m -> Proxy f -> Proxy tag
119+ getResp :: XhrResponse -> EOutput t m api f
82− -> f ReqR -> Dynamic t BaseUrl
83− -> ClientOptions -> EndpointResult t m api f tag
84
120
85
121
122+------------------------------------------------------------------------------
123+-- | :<|> APIs
124+instance {-# OVERLAPPING #-}
86−instance {-# OVERLAPPING #-} (HasClientR t m (layoutLeft) f tag,
125+ (HasClientR t m (layoutLeft) f,
87− HasClientR t m (layoutRight) f tag
126+ HasClientR t m (layoutRight) f
88− ) => HasClientR t m (layoutLeft :<|> layoutRight) f tag where
127+ ) => HasClientR t m (layoutLeft :<|> layoutRight) f where
89− type ClientR t m (layoutLeft :<|> layoutRight) f tag =
128+ type ClientR t m (layoutLeft :<|> layoutRight) f =
90− ClientR t m (layoutLeft) f tag :<|> ClientR t m (layoutRight) f tag
129+ ClientR t m layoutLeft f :<|> ClientR t m layoutRight f
91− clientRWithRoute _ tP mP tagP _ url opts =
130+ clientRWithRoute _ tP mP _ url opts =
92− clientRWithRoute (Proxy @(layoutLeft)) tP mP tagP undefined url opts
131+ clientRWithRoute (Proxy @layoutLeft) tP mP undefined url opts
93 :<|>
132 :<|>
94− clientRWithRoute (Proxy @(layoutRight)) tP mP tagP undefined url opts
133+ clientRWithRoute (Proxy @layoutRight) tP mP undefined url opts
95−
96
134
97−
135+#if MIN_VERSION_servant (0,13,0)
136+-- TODO: Untested
98−-- instance {-# OVERLAPPING #-} (HasClientR t m (Sealed layoutLeft) f tag,
137+instance HasClientR t m EmptyClient f where
99−-- HasClientR t m (Sealed layoutRight) f tag
138+ type ClientR t m api f = EmptyClient
100−-- ) => HasClientR t m (Sealed layoutLeft :<|> Sealed layoutRight) f tag where
101−-- type ClientR t m (Sealed layoutLeft :<|> Sealed layoutRight) f tag =
102−-- ClientR t m (Sealed layoutLeft) f tag :<|> ClientR t m (Sealed layoutRight) f tag
103−-- clientRWithRoute _ tP mP tagP _ url opts =
139+ clientRWithRoute _ _ _ _ _ _ = EmptyClient
104−-- clientRWithRoute (Proxy @(Sealed layoutLeft)) tP mP tagP undefined url opts
140+#endif
105−-- :<|>
106−-- clientRWithRoute (Proxy @(Sealed layoutRight)) tP mP tagP undefined url opts
107
141
108
142
109class ToTuple xs where
143class ToTuple xs where
@@ -111,194 +145,304 @@ class ToTuple xs where
111 toTuple :: xs -> Tuple xs
145 toTuple :: xs -> Tuple xs
112 fromTuple :: Tuple xs -> xs
146 fromTuple :: Tuple xs -> xs
113
147
114−-- class FromTuple xs where
115−-- type UnTuple xs :: *
116−-- fromTuple :: Tuple xs -> xs
117−
118data Sealed a
148data Sealed a
149+data SealedRaw
119
150
120type family Seal a where
151type family Seal a where
121 Seal (a :<|> b) = Seal a :<|> Seal b
152 Seal (a :<|> b) = Seal a :<|> Seal b
153+ Seal Raw = SealedRaw
122 Seal a = Sealed a
154 Seal a = Sealed a
123
155
156+
124-- | Turn a single Endpoint into a client, by turning the input HList
157-- | Turn a single Endpoint into a client, by turning the input HList
125-- into a tuple
158-- into a tuple
126−instance {-# OVERLAPPING #-} forall t m layout f tag .(EndpointR t m layout f tag,
159+instance {-# OVERLAPPING #-} forall t m layout f .(EndpointR t m layout f,
127− ToTuple (HList (EInputs t m layout f tag)),
160+ ToTuple (HList (EInputs t m layout f)),
128 Monad m
161 Monad m
129 , Traversable f
162 , Traversable f
130 , SupportsServantReflex t m
163 , SupportsServantReflex t m
131− ) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) tag where
164+ ) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) where
132− type ClientR t m (Sealed layout) f tag =
165+ type ClientR t m (Sealed layout) f =
133− Event t (f (Tuple (HList (EInputs t m layout f tag))))
166+ Event t (f (Tuple (HList (EInputs t m layout f))))
134− -> m (Event t (f (EOutput t m layout f tag)))
167+ -> m (Event t (f (EOutput t m layout f)))
135− clientRWithRoute _ mP fP tagP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f tag))))) = do
168+ clientRWithRoute _ mP fP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f ))))) = do
136− let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f tag))) <$> reqs
169+ let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f ))) <$> reqs
170+
171+ -- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging
172+ reqRs = traceEventWith (concat . fmap ((<> "\n") . show)) $ fmap (mkReq @t @m @layout @f) <$> reqTuples
173+ reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl <$> rs
137− reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
174+ -- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
138− mkXhrRequest bUrl . mkReq @t @m @layout @f @tag <$> inputs
175+ -- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs
139− resps <- performRequestsAsync reqs'
176+ resps <- performRequestsAsync $ reqs'
140− return (fmap (getResp @t @m @layout @f @tag) <$> resps)
177+ return (fmap (getResp @t @m @layout @f) <$> resps)
141−
178+
142−
179+
143−instance (SupportsServantReflex t m, Traversable f) => HasClientR t m Raw f tag where
180+instance (SupportsServantReflex t m, Traversable f) => HasClientR t m SealedRaw f where
144− type ClientR t m Raw f tag = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
181+ type ClientR t m SealedRaw f = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
145− clientRWithRoute _ mP fP tagP dReq url opts reqs = performRequestsAsync reqs
182+ clientRWithRoute _ mP fP dReq url opts reqs = performRequestsAsync reqs
146−
183+
147−
184+
148−instance (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f
185+instance {-# OVERLAPPING #-}(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f
149− ) => EndpointR t m (Verb method status cts' a) f (tag :: *) where
186+ ) => EndpointR t m (Verb method status cts' a) f where
150− type EndpointResult t m (Verb method status cts' a) f tag = Event t tag -> m (Event t (ReqResult tag a))
151− type EInputs t m (Verb method status cts' a) f tag = '[]
187+ type EInputs t m (Verb method status cts' a) f = '[]
152− type EOutput t m (Verb method status cts' a) f tag = Either String a
188+ type EOutput t m (Verb method status cts' a) f = Either String a
153−
189+
154− eInputs = HNil
155− clientEndpoint _ _ _ _ _ _ _ = undefined
156 mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
190 mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
157 getResp resp = case _xhrResponse_response resp of
191 getResp resp = case _xhrResponse_response resp of
158 Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
192 Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
159
193
160−-- type ClientFunction t m f tag ein eout = Event t (f (tag, Tuple (HList ein))) -> m (Event t (f (tag, eout)))
194+instance {-# OVERLAPPING #-}(ReflectMethod method, SupportsServantReflex t m, Applicative f
195+ ) => EndpointR t m (Verb method status cts' NoContent) f where
196+ type EInputs t m (Verb method status cts' NoContent) f = '[]
197+ type EOutput t m (Verb method status cts' NoContent) f = Either String NoContent
198+
199+ mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
200+ getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?
201+
202+
203+instance {-# OVERLAPPING #-}
204+ (MimeUnrender ct a,
205+ BuildHeadersTo hs,
206+ ReflectMethod method, cts' ~ (ct ': cts),
207+ SupportsServantReflex t m,
208+ Applicative f,
209+ BuildHeaderKeysTo hs
210+ ) => EndpointR t m (Verb method status cts' (Headers hs a)) f where
211+ type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]
212+ type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)
213+
214+ mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)
215+ getResp resp = case _xhrResponse_response resp of
216+ Just (XhrResponseBody_ArrayBuffer x) ->
217+ let hs = buildHeadersTo
218+ . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
219+ . M.toList
220+ $ _xhrResponse_headers resp
221+ in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)
222+
223+
224+instance {-# OVERLAPPING #-}(MimeUnrender ct a,
225+ BuildHeadersTo hs,
226+ BuildHeaderKeysTo hs,
227+ ReflectMethod method,
228+ SupportsServantReflex t m,
229+ Applicative f
230+ ) => EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where
231+ type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]
232+ type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)
233+
234+ mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
235+ getResp resp = case _xhrResponse_response resp of
236+ Just (XhrResponseBody_ArrayBuffer x) ->
237+ let hs = buildHeadersTo
238+ . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
239+ . M.toList
240+ $ _xhrResponse_headers resp
241+ in Right (Headers NoContent hs)
242+
161
243
162instance (SupportsServantReflex t m,
244instance (SupportsServantReflex t m,
163 ToHttpApiData a,
245 ToHttpApiData a,
164− EndpointR t m sublayout f tag,
246+ EndpointR t m sublayout f,
165 Applicative f
247 Applicative f
166− ) => EndpointR t m (Capture capture a :> sublayout) f (tag :: *) where
248+ ) => EndpointR t m (Capture capture a :> sublayout) f where
249+
250+ type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f
251+ type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f
252+
253+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $
254+ mkReq @t @m @sublayout @f xs
167
255
168− type EndpointResult t m (Capture capture a :> sublayout) f tag =
169− f a ->
170− EndpointResult t m sublayout f tag
256+ getResp = getResp @t @m @sublayout @f
171
257
172− type EInputs t m (Capture capture a :> sublayout) f tag = a ': EInputs t m sublayout f tag
258+instance (SupportsServantReflex t m,
173− type EOutput t m (Capture capture a :> sublayout) f tag = EOutput t m sublayout f tag
259+ ToHttpApiData a,
174− eInputs = undefined
260+ EndpointR t m sublayout f,
175− clientEndpoint _ pM pF pTag reqs url opts vals =
261+ Applicative f
176− clientEndpoint (Proxy :: Proxy sublayout) pM pF pTag reqs' url opts
262+ ) => EndpointR t m (CaptureAll capture a :> sublayout) f where
177− where reqs' = (\v -> over (field @"reqRPathParts") (toUrlPiece v :))
178− <$> vals
179− <*> reqs
180− mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $ mkReq @t @m @sublayout @f @tag xs
181
263
264+ type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f
265+ type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f
266+
267+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $
268+ mkReq @t @m @sublayout @f xs
269+
182− getResp = getResp @t @m @sublayout @f @tag
270+ getResp = getResp @t @m @sublayout @f
183
271
184
272
185instance (SupportsServantReflex t m,
273instance (SupportsServantReflex t m,
186 KnownSymbol sym,
274 KnownSymbol sym,
187− EndpointR t m sublayout f tag,
275+ EndpointR t m sublayout f,
188 Applicative f
276 Applicative f
189− ) => EndpointR t m (sym :> sublayout) f (tag :: *) where
277+ ) => EndpointR t m (sym :> sublayout) f where
278+
279+ type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f
280+ type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f
190
281
191− type EndpointResult t m (sym :> sublayout) f tag =
282+ mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r
192− EndpointResult t m sublayout f tag
193
283
194− type EInputs t m (sym :> sublayout) f tag = EInputs t m sublayout f tag
284+ getResp = getResp @t @m @sublayout @f
195− type EOutput t m (sym :> sublayout) f tag = EOutput t m sublayout f tag
196− clientEndpoint _ pM pF pTag reqs url opts =
197− clientEndpoint (Proxy :: Proxy sublayout) pM pF pTag reqs' url opts
198− where reqs' = (over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :))
199− <$> reqs
200− mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f @tag r
201
285
202− getResp = getResp @t @m @sublayout @f @tag
203instance (SupportsServantReflex t m,
286instance (SupportsServantReflex t m,
204 ToHttpApiData a,
287 ToHttpApiData a,
205− EndpointR t m sublayout f tag,
288+ EndpointR t m sublayout f,
206 KnownSymbol sym,
289 KnownSymbol sym,
207 Applicative f
290 Applicative f
208− ) => EndpointR t m (QueryParam sym a :> sublayout) f (tag :: *) where
291+ ) => EndpointR t m (QueryParam sym a :> sublayout) f where
209−
292+
210− type EndpointResult t m (QueryParam sym a :> sublayout) f tag =
211− f a ->
212− EndpointResult t m sublayout f tag
213−
214− type EInputs t m (QueryParam sym a :> sublayout) f tag = Maybe a ': EInputs t m sublayout f tag
293+ type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f
215− type EOutput t m (QueryParam sym a :> sublayout) f tag = EOutput t m sublayout f tag
294+ type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f
216− clientEndpoint _ pM pF pTag reqs url opts vals = undefined -- TODO
295+
217− -- clientEndpoint (Proxy :: Proxy sublayout) pM pF pTag reqs' url opts
218− -- where reqs' = (\v -> over (field @"reqRPathParts") (toUrlPiece v :))
219− -- <$> vals
220− -- <*> reqs
221 mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
296 mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
222 QueryPartParam $ fmap (toQueryParam) x) : ) $
297 QueryPartParam $ fmap (toQueryParam) x) : ) $
223− mkReq @t @m @sublayout @f @tag xs
298+ mkReq @t @m @sublayout @f xs
224
299
225
300
226− getResp = getResp @t @m @sublayout @f @tag
301+ getResp = getResp @t @m @sublayout @f
227
302
228instance (SupportsServantReflex t m,
303instance (SupportsServantReflex t m,
229 ToHttpApiData a,
304 ToHttpApiData a,
230− EndpointR t m sublayout f tag,
305+ EndpointR t m sublayout f,
231 KnownSymbol sym,
306 KnownSymbol sym,
232 Applicative f
307 Applicative f
233− ) => EndpointR t m (QueryParams sym a :> sublayout) f (tag :: *) where
308+ ) => EndpointR t m (QueryParams sym a :> sublayout) f where
234
309
235− type EndpointResult t m (QueryParams sym a :> sublayout) f tag =
310+ type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f
236− f a ->
311+ type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f
237− EndpointResult t m sublayout f tag
238
312
239− type EInputs t m (QueryParams sym a :> sublayout) f tag = [a] ': EInputs t m sublayout f tag
240− type EOutput t m (QueryParams sym a :> sublayout) f tag = EOutput t m sublayout f tag
241− eInputs = undefined
242− clientEndpoint _ pM pF pTag reqs url opts vals = undefined -- TODO
243 mkReq (HCons x xs) =
313 mkReq (HCons x xs) =
244 let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
314 let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
245− in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f @tag xs
315+ in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs
246
316
247− getResp = getResp @t @m @sublayout @f @tag
317+ getResp = getResp @t @m @sublayout @f
248
318
249instance (SupportsServantReflex t m,
319instance (SupportsServantReflex t m,
250− EndpointR t m sublayout f tag,
320+ EndpointR t m sublayout f,
251 KnownSymbol sym,
321 KnownSymbol sym,
252 Applicative f
322 Applicative f
253− ) => EndpointR t m (QueryFlag sym :> sublayout) f (tag :: *) where
323+ ) => EndpointR t m (QueryFlag sym :> sublayout) f where
254
324
255− type EndpointResult t m (QueryFlag sym :> sublayout) f tag =
256− f Bool ->
257− EndpointResult t m sublayout f tag
258−
259− type EInputs t m (QueryFlag sym :> sublayout) f tag = Bool ': EInputs t m sublayout f tag
325+ type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f
260− type EOutput t m (QueryFlag sym :> sublayout) f tag = EOutput t m sublayout f tag
326+ type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f
261
327
262 mkReq (HCons x xs) =
328 mkReq (HCons x xs) =
263 let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
329 let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
264− in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f @tag xs
330+ in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs
265
331
266− getResp = getResp @t @m @sublayout @f @tag
332+ getResp = getResp @t @m @sublayout @f
267
333
268instance (SupportsServantReflex t m,
334instance (SupportsServantReflex t m,
269− EndpointR t m sublayout f tag,
335+ EndpointR t m sublayout f,
270 MimeRender ct a,
336 MimeRender ct a,
271 Applicative f
337 Applicative f
272− ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f (tag :: *) where
338+ ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where
273
339
274− type EndpointResult t m ( ReqBody (ct ': cts) a :> sublayout) f tag =
275− f Bool ->
276− EndpointResult t m sublayout f tag
277
340
278− type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f tag = a ': EInputs t m sublayout f tag
341+ type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f
279− type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f tag = EOutput t m sublayout f tag
342+ type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f
280
343
281 mkReq (HCons x xs) =
344 mkReq (HCons x xs) =
282− set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f @tag xs
345+ set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs
346+
347+ getResp = getResp @t @m @sublayout @f
283
348
284− getResp = getResp @t @m @sublayout @f @tag
285
349
286instance (SupportsServantReflex t m,
350instance (SupportsServantReflex t m,
287− EndpointR t m sublayout f tag,
351+ EndpointR t m sublayout f,
352+ KnownSymbol sym,
353+ ToHttpApiData a,
288 Applicative f
354 Applicative f
289− ) => EndpointR t m (BasicAuth realm usr :> sublayout) f (tag :: *) where
355+ ) => EndpointR t m (Header sym a :> sublayout) f where
290
356
291− type EndpointResult t m ( BasicAuth realm usr :> sublayout) f tag =
292− f Bool ->
293− EndpointResult t m sublayout f tag
294
357
295− type EInputs t m (BasicAuth realm usr :> sublayout) f tag = BasicAuthData ': EInputs t m sublayout f tag
358+ type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f
296− type EOutput t m (BasicAuth realm usr :> sublayout) f tag = EOutput t m sublayout f tag
359+ type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f
297
360
298 mkReq (HCons x xs) =
361 mkReq (HCons x xs) =
362+ over (field @"reqRHeaders")
363+ -- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)
364+ ((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)
299− set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f @tag xs
365+ $ mkReq @t @m @sublayout @f xs
366+
367+ getResp = getResp @t @m @sublayout @f
368+
369+#if MIN_VERSION_servant(0,13,0)
370+-- TODO: Untested
371+instance (SupportsServantReflex t m,
372+ EndpointR t m sublayout f,
373+ KnownSymbol sym,
374+ ToHttpApiData a,
375+ Applicative f
376+ ) => EndpointR t m (Summary desc :> sublayout) f where
300
377
378+ type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f
379+ type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f
380+
381+ mkReq = mkReq @t @m @sublayout @f
382+
301− getResp = getResp @t @m @sublayout @f @tag
383+ getResp = getResp @t @m @sublayout @f
384+#endif
385+
386+
387+#if MIN_VERSION_servant(0,13,0)
388+-- TODO: Untested
389+instance (SupportsServantReflex t m,
390+ EndpointR t m sublayout f,
391+ KnownSymbol sym,
392+ ToHttpApiData a,
393+ Applicative f
394+ ) => EndpointR t m (Description desc :> sublayout) f where
395+
396+ type EInputs t m (Descriptiok desc :> sublayout) f = EInputs t m sublayout f
397+ type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f
398+
399+ mkReq = mkReq @t @m @sublayout @f
400+
401+ getResp = getResp @t @m @sublayout @f
402+#endif
403+
404+instance (SupportsServantReflex t m,
405+ EndpointR t m sublayout f,
406+ KnownSymbol sym,
407+ ToHttpApiData a,
408+ Applicative f
409+ ) => EndpointR t m (IsSecure :> sublayout) f where
410+
411+
412+ type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f
413+ type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f
414+
415+ mkReq = mkReq @t @m @sublayout @f
416+
417+ getResp = getResp @t @m @sublayout @f
418+
419+instance (SupportsServantReflex t m,
420+ EndpointR t m sublayout f,
421+ KnownSymbol sym,
422+ ToHttpApiData a,
423+ Applicative f
424+ ) => EndpointR t m (Vault :> sublayout) f where
425+
426+
427+ type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f
428+ type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f
429+
430+ mkReq = mkReq @t @m @sublayout @f
431+
432+ getResp = getResp @t @m @sublayout @f
433+
434+instance (SupportsServantReflex t m,
435+ EndpointR t m sublayout f,
436+ Applicative f
437+ ) => EndpointR t m (BasicAuth realm usr :> sublayout) f where
438+
439+ type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f
440+ type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f
441+
442+ mkReq (HCons x xs) =
443+ set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs
444+
445+ getResp = getResp @t @m @sublayout @f
302
446
303
447
304instance ToTuple (HList '[]) where
448instance ToTuple (HList '[]) where
@@ -321,18 +465,25 @@ instance ToTuple (HList '[a,b,c]) where
321 toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
465 toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
322 fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
466 fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
323
467
324−type MyAPI = Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] Int
468+type MyAPI = Header "hi" Int :> Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] (Headers '[Header "hi" Int] Int)
325 :<|> Get '[JSON] Bool
469 :<|> Get '[JSON] Bool
326
470
471+type MyAPI2 = Raw
472+
327
473
328m :: forall t m.MonadWidget t m => m ()
474m :: forall t m.MonadWidget t m => m ()
329m = do
475m = do
330− let (a :<|> b) = clientR (Proxy @(MyAPI)) (Proxy :: Proxy m) (Proxy :: Proxy t)
476+ let (a :<|> b) = clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t)
331− (Proxy @[]) (Proxy @Integer) undefined
477+ (Proxy @[]) undefined
332 btn <- button "Hello"
478 btn <- button "Hello"
333− resA <- a (fmap (:[]) ((5,True) <$ btn))
479+ resA <- a (fmap (:[]) ((2, 5,True) <$ btn))
334 resB <- b (fmap (:[]) (() <$ btn))
480 resB <- b (fmap (:[]) (() <$ btn))
335− display =<< holdDyn "waiting" (leftmost [show <$> resA, show <$> resB])
481+ display =<< holdDyn "waiting" (leftmost [show <$> resB ])
482+ -- [show <$> resA
483+ -- , show <$> resB
484+ -- ])
485+
486+ let rawR = clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) (Proxy @[]) undefined
336 return ()
487 return ()
337
488
338data ReqR = ReqR
489data ReqR = ReqR
@@ -345,12 +496,25 @@ data ReqR = ReqR
345 , reqRAuthData :: Maybe BasicAuthData
496 , reqRAuthData :: Maybe BasicAuthData
346 } deriving (Generic)
497 } deriving (Generic)
347
498
499+instance Show ReqR where
500+ show (ReqR m pp ps b hs hs' a) = concat $ L.intersperse "\n" [
501+ "ReqR {"
502+ , ("reqRMethod = " <> show m)
503+ , ("reqRPathParts = " <> show pp)
504+ , ("reqRParams = " <> show ps)
505+ , ("reqRBody = " <> show b)
506+ , ("reqRHeaders = " <> show hs)
507+ , ("reqRRespHeaders = " <> show hs')
508+ , ("reqRAuthData = " <> maybe "Nothing" (const "Just <<redacted>>") a)
509+ ]
510+
348emptyReqR :: T.Text -> ReqR
511emptyReqR :: T.Text -> ReqR
349emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing
512emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing
350
513
351data QueryPart = QueryPartParam (Maybe Text)
514data QueryPart = QueryPartParam (Maybe Text)
352 | QueryPartParams [Text]
515 | QueryPartParams [Text]
353 | QueryPartFlag Bool
516 | QueryPartFlag Bool
517+ deriving (Show)
354
518
355mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text
519mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text
356mkXhrRequest reqHost req =
520mkXhrRequest reqHost req =
@@ -376,15 +540,28 @@ mkXhrRequest reqHost req =
376 queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req
540 queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req
377 url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)
541 url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)
378
542
379− xhrHeaders = [] -- TODO
543+ (headers, body) =
544+ let headers0 = M.fromList $ reqRHeaders req
545+ in case reqRBody req of
546+ Nothing -> (headers0, "")
547+ Just (rb,ct) -> (M.insert "Content-Type" ct headers0,
548+ E.decodeUtf8 $ BL.toStrict rb)
380
549
381 xhrReqConfig = def
550 xhrReqConfig = def
382− { _xhrRequestConfig_headers = M.fromList xhrHeaders
551+ { _xhrRequestConfig_headers = headers
383 , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
552 , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
384 , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
553 , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
385 , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
554 , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
386− , _xhrRequestConfig_sendData = "" -- TODO
555+ , _xhrRequestConfig_sendData = body
556+ , _xhrRequestConfig_responseHeaders = reqRRespHeaders req
387 , _xhrRequestConfig_withCredentials = False
557 , _xhrRequestConfig_withCredentials = False
388 }
558 }
389 xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
559 xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
390 in xhrReq
560 in xhrReq
561+
562+transformExample :: MonadWidget t m => ((Int, Char) -> Performable m Bool) -> Event t (Int, Char) -> m (Event t Bool)
563+transformExample f = \triggers -> performEvent (f <$> triggers)
564+-- transformExample = undefined -- let x = performEvent :: _ in undefined
565+
566+transform :: MonadWidget t m => forall a. (inp -> IO outp) -> (Event t inp -> m (Event t outp))
567+transform = undefined
testserver/API.hs+3−1
@@ -40,7 +40,9 @@ type API = "getunit" :> Get '[JSON] ()
40 :> Post '[JSON] Double
40 :> Post '[JSON] Double
41 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
42 :<|> "qna" :> ReqBody '[JSON] Question
42 :<|> "qna" :> ReqBody '[JSON] Question
43+ :> Header "qnum" Int
44+ :> Header "is-favorite" Bool
43− :> Post '[JSON] Answer
45+ :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)
44 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
46 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
45 :<|> Raw
47 :<|> Raw
46
48
testserver/Main.hs+6−6
@@ -11,6 +11,7 @@ import Data.Aeson
11import Data.Bool
11import Data.Bool
12import Data.Char (toUpper)
12import Data.Char (toUpper)
13import qualified Data.List as L
13import qualified Data.List as L
14+import Data.Maybe (fromMaybe)
14import Data.Monoid
15import Data.Monoid
15import Data.Proxy
16import Data.Proxy
16import Data.Text hiding (head, length, map,
17import Data.Text hiding (head, length, map,
@@ -18,7 +19,7 @@ import Data.Text hiding (head, length, map,
18import qualified Data.Text as T
19import qualified Data.Text as T
19import qualified Data.Text.IO as T
20import qualified Data.Text.IO as T
20import GHC.Generics
21import GHC.Generics
21−import Snap.Core
22+import Snap.Core hiding (addHeader)
22import Snap.Http.Server
23import Snap.Http.Server
23
24
24import Servant
25import Servant
@@ -26,7 +27,7 @@ import Servant.Server ()
26import System.Directory
27import System.Directory
27-- import Snap.Util.FileServe
28-- import Snap.Util.FileServe
28import API
29import API
29−import Snap
30+import Snap hiding (addHeader)
30
31
31-- * Example
32-- * Example
32
33
@@ -50,8 +51,7 @@ data App = App
50-- Each handler runs in the 'ExceptT ServantErr IO' monad.
51-- Each handler runs in the 'ExceptT ServantErr IO' monad.
51server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
52server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
52server = return () :<|> return 100 :<|> dblint :<|> sayhi :<|> dbl
53server = return () :<|> return 100 :<|> dblint :<|> sayhi :<|> dbl
53− :<|> multi :<|> qna :<|> serveSecret
54− :<|> serveDirectory "static"
54+ :<|> multi :<|> qna :<|> serveSecret :<|> serveDirectory "static"
55 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
55 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
56 sayhi nm greetings withGusto = case nm of
56 sayhi nm greetings withGusto = case nm of
57 Nothing -> return ("Sorry, who are you?" :: Text)
57 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -68,11 +68,11 @@ server = return () :<|> return 100 :<|> dblint :<|> sayhi :<|> dbl
68 then throwError $ err500 { errBody = "No unlucky numbers please" }
68 then throwError $ err500 { errBody = "No unlucky numbers please" }
69 else return $ x * 2
69 else return $ x * 2
70 multi = return . bool "Box unchecked" "Box Checked"
70 multi = return . bool "Box unchecked" "Box Checked"
71− qna q = do
71+ qna q nm fav = do
72 liftIO $ do
72 liftIO $ do
73 putStrLn $ "qna got: " ++ show q
73 putStrLn $ "qna got: " ++ show q
74 T.putStrLn $ unQuestion q
74 T.putStrLn $ unQuestion q
75− return $ Answer $ unQuestion q
75+ return $ addHeader (fromMaybe 10 nm) $ addHeader (fromMaybe False fav) $ (Answer $ unQuestion q)
76 serveSecret _ = do
76 serveSecret _ = do
77 req <- getRequest
77 req <- getRequest
78 liftIO $ putStrLn (show req)
78 liftIO $ putStrLn (show req)
testserver/shell.nix+1−1
@@ -1 +1 @@
1−(import ../release2.nix {}).testserver.env
1+(import ../release.nix {}).testserver.env