git.iko.soy/typeable/servant-reflex
on tuple-api-3 help sign in
typeable/servant-reflex/exec/Example.hs
358 lines 13 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeOperators #-}
11module Main where
13------------------------------------------------------------------------------
14import Data.Bool
15import Data.Maybe
16import Control.Monad.Fix (MonadFix)
17import Data.Monoid (First(..), (<>))
18import Data.Text (Text)
19import qualified Data.Text as T
20import qualified Data.Text.Encoding as T
21import GHC.TypeLits
22import Servant.API
23import API
24import Data.Proxy
25import Text.Read (readMaybe)
26import Reflex.Dom.Core hiding (run)
27------------------------------------------------------------------------------
28import Servant.Reflex
29import Servant.Reflex.Multi
30import qualified Servant.Reflex.RequestAPI as SR
33api :: Proxy API
34api = Proxy
36type MyAPI =
37 "getunit" :> Get '[JSON] ()
38 :<|> "getint" :> Get '[JSON] Int
39 :<|> "dblint" :> Capture "anint" Int :> Get '[JSON] Int
40 :<|> "sayhi" :> QueryParam "username" Text
41 :> QueryParams "greetings" Text
42 :> QueryFlag "gusto"
43 :> Get '[JSON] Text
44 :<|> "double" :> ReqBody '[JSON] Double
45 :> Post '[JSON] Double
46 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
47 :<|> "qna" :> ReqBody '[JSON] Question
48 :> Header "qnum" Int
49 :> Header "is-favorite" Bool
50 :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)
51 :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
53main :: IO ()
54main = mainWidget $ do
55 divClass "example-tuple" runTuple
56 divClass "example-base" run
57 divClass "example-multi" runMulti
59hiWidget :: (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 ())
66hiWidget = 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 ()
73 text "Greetings (space-separated)"
74 el "br" $ return ()
75 greetings <- fmap (fmap T.words . value) $
76 divClass "greetings-input" $ (textInput def)
78 el "br" $ return ()
80 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
82 el "br" $ return ()
83 sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
84 return (checkedName, greetings, gusto, sayHiClicks)
87readWidget :: (SupportsServantReflex t m,
88 DomBuilder t m,
89 DomBuilderSpace m ~ GhcjsDomSpace,
90 PostBuild t m,
91 Read a
92 ) => m (Dynamic t (Maybe a))
93readWidget = fmap (readMaybe . T.unpack) . value <$> textInput def
95readWidget' :: (SupportsServantReflex t m,
96 DomBuilder t m,
97 DomBuilderSpace m ~ GhcjsDomSpace,
98 PostBuild t m,
99 Read a
100 ) => a -> m (Dynamic t a)
101readWidget' d = fmap (fromMaybe d . readMaybe . T.unpack) . value <$> textInput def
103basicAuthWidget :: (SupportsServantReflex t m,
104 DomBuilder t m,
105 DomBuilderSpace m ~ GhcjsDomSpace,
106 PostBuild t m
107 ) => m (Dynamic t BasicAuthData)
108basicAuthWidget = 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
114runTuple :: forall t m. (SupportsServantReflex t m,
115 DomBuilder t m,
116 DomBuilderSpace m ~ GhcjsDomSpace,
117 MonadFix m,
118 PostBuild t m,
119 MonadHold t m) => m ()
120runTuple = do
121 el "h1" (text "Tuple API")
122 url <- baseUrlWidget
124 let (getUnit :<|> getInt :<|> dblInt :<|> sayHi :<|> dbl :<|> ab :<|> question :<|> secret :<|> _) =
125 SR.clientR (Proxy @API) (Proxy @m) (Proxy @t) (Proxy @[]) url
127 u <- divClass "demo-group" $ do
128 unitBtn <- button "get unit"
129 getUnit (fmap (:[]) unitBtn)
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)
139 hiResp <- divClass "demo-group" $ do
140 (nm, greets, gusto, hiClicks) <- hiWidget
141 let hiReqs = tagPromptlyDyn ((,,) <$> nm <*> greets <*> gusto) hiClicks
142 sayHi (fmap (:[]) hiReqs)
144 dblResp <- divClass "demo-group" $ do
145 dblInput <- readWidget
146 dblBtn <- button "double double"
147 dbl $ (fmap (:[])) $ fmapMaybe id $ tagPromptlyDyn dblInput dblBtn
149 twoPathResp <- divClass "demo-group" $ do
150 twoPathInp <- text "Two Path" >> checkbox False def
151 ab (fmap (:[]) $ updated (value twoPathInp))
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))
159 secretR <- divClass "demo-group" $ do
160 ba <- basicAuthWidget
161 sBtn <- button "Get secret"
162 secret (fmap pure $ tagPromptlyDyn ba sBtn)
164 divClass "demo-group" $ do
165 el "div" $ text "responses"
166 dynText =<< holdDyn "No responses yet"
167 (leftmost [ tshow <$> u , tshow <$> giR
168 , tshow <$> diR
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 ])
175 return ()
178runMulti :: forall t m. (SupportsServantReflex t m,
179 DomBuilder t m,
180 DomBuilderSpace m ~ GhcjsDomSpace,
181 MonadFix m,
182 PostBuild t m,
183 MonadHold t m) => m ()
184runMulti = do
185 url <- baseUrlWidget
186 el "br" blank
187 let (_ :<|> _ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
188 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
190 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
191 num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
193 b <- button "Run dbl multi"
194 reqCount :: Dynamic t Int <- count b
195 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
196 dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
198 lastInd <- holdDyn [] $ fmap reqTag <$> r
199 display lastInd
201 divClass "demo-group" $ do
202 nms <- fmap (fmap T.words . value) $ divClass "" $ do
203 text "Names"
204 textInput def
205 grts <- fmap (fmap T.words . value) $ divClass "" $ do
206 text "Greetings"
207 textInput def
208 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
209 b <- button "Go"
210 r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
211 (constDyn [True, False]) (1 <$ b)
213 dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
214 fmap reqSuccess <$> r')
217 return ()
219run :: forall t m. (SupportsServantReflex t m,
220 DomBuilder t m,
221 DomBuilderSpace m ~ GhcjsDomSpace,
222 MonadFix m,
223 PostBuild t m,
224 MonadHold t m) => m ()
225run = mdo
227 reqCount <- count $ leftmost
228 [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
229 -- Allow user to choose the url target for the request
230 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
231 url <- baseUrlWidget
232 el "br" (return ())
233 dynText $ showBaseUrl <$> url
235 el "br" (return ())
237 -- Name the computed API client functions
238 let tweakRequest = ClientOptions $ \r -> do
239 return $ r & withCredentials .~ True
240 let (getUnit :<|> getInt :<|> dblInt :<|> sayhi :<|> dbl
241 :<|> multi :<|> qna :<|> secret :<|> doRaw) =
242 clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
244 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
246 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
247 unitBtn <- divClass "unit-button" $ button "Get unit"
248 intBtn <- divClass "int-button" $ button "Get int"
250 unitResponse <- getUnit $ tag (current reqCount) unitBtn
251 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
253 score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
255 r <- holdDyn "Waiting" $ fmap showXhrResponse $
256 leftmost [fmapMaybe response (unitResponse)
257 ,fmapMaybe response (intResponse)
258 ]
259 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
260 return (unitBtn, intBtn)
262 sayHiClicks <- elClass "div" "demo-group" $ do
264 text "Name"
265 el "br" $ return ()
266 inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
267 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
268 el "br" $ return ()
270 text "Greetings (space-separated)"
271 el "br" $ return ()
272 greetings <- fmap (fmap T.words . value) $
273 divClass "greetings-input" $ (textInput def)
275 el "br" $ return ()
277 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
279 el "br" $ return ()
280 sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
281 let triggers = leftmost [sayHiClicks, () <$ updated inp]
283 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
284 divClass "greeting-response" $ dynText =<<
285 holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
286 , fmapMaybe reqFailure (resp)])
287 return sayHiClicks
289 dblBtn <- elClass "div" "demo-group" $ do
290 text "A Double to double"
291 el "br" $ return ()
292 dblinp <- fmap value $ divClass "double-input" $ textInput def
293 (dblBtn) <- divClass "double-button" $ button "Double it"
294 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
295 dblinp) (tag (current reqCount) dblBtn)
296 divClass "double-errors" $ dynText =<<
297 holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
298 el "br" (return ())
299 divClass "double-result" $ el "p" $ dynText =<<
300 holdDyn "No number yet" (fmap tshow $
301 fmapMaybe reqSuccess (dblResp))
302 return dblBtn
304 mpGo <- elClass "div" "demo-group" $ do
305 text "Multi-part path"
306 b <- value <$> checkbox False def
307 mpGo <- button "Test"
308 multiResp <- multi b (tag (current reqCount) mpGo)
309 dynText =<< holdDyn "No res yet" (fmap tshow $
310 fmapMaybe reqSuccess $
311 (multiResp))
312 return mpGo
314 return ()
316 el "br" $ return ()
318 elClass "div" "demo-group" $ do
319 text "JSON Unicode encoding test"
320 txt <- value <$> textInput def
321 ev <- fmap (1 <$) $ button "Question"
322 let dQ = Right . Question <$> traceDyn "will send: " txt
323 -- rr <- qna dQ ev _ _
324 el "p" $
325 return ()
326 -- dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
328 divClass "demo-group" $ do
329 un <- fmap value $ text "Username" >> textArea def
330 pw <- fmap value $ text "Unhidden PW" >> textArea def
331 let ba :: Dynamic t BasicAuthData = BasicAuthData
332 <$> fmap T.encodeUtf8 un
333 <*> fmap T.encodeUtf8 pw
334 b <- button "Get secret"
335 r <- secret (Just <$> ba) (0 <$ b)
336 res <- holdDyn Nothing (reqSuccess <$> r)
337 display res
340showXhrResponse :: XhrResponse -> Text
341showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
342 T.unlines ["stat: " <> tshow stat
343 ,"stattxt: " <> tshow stattxt
344 ,"resp: " <> maybe "" showRB rbmay
345 ,"rtext: " <> tshow rtmay
346 ,"rHeaders: " <> tshow respHeaders]
348tshow :: Show a => a -> Text
349tshow = T.pack . show
351showRB :: XhrResponseBody -> Text
352showRB (XhrResponseBody_Default t) = tshow t
353showRB (XhrResponseBody_Text t) = tshow t
354showRB (XhrResponseBody_Blob t) = "<Blob>"
355showRB (XhrResponseBody_ArrayBuffer t) = tshow t
357note :: e -> Maybe a -> Either e a
358note e = maybe (Left e) Right