git.iko.soy/servant-reflex
on json-native help sign in
servant-reflex/exec/Example.hs
198 lines 7.1 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE ScopedTypeVariables #-}
8module Main where
10------------------------------------------------------------------------------
11import Data.Bool
12import Data.Maybe
13import Control.Monad.Fix (MonadFix)
14import Data.Monoid (First(..), (<>))
15import Data.Text (Text)
16import qualified Data.Text as T
17import GHC.TypeLits
18import Servant.API
19import API
20import Data.Proxy
21import Text.Read (readMaybe)
22import Reflex.Dom
23------------------------------------------------------------------------------
24import Servant.Reflex
25import Servant.Reflex.Multi
28api :: Proxy API
29api = Proxy
31main :: IO ()
32main = mainWidget $ do
33 divClass "example-base" run
34 divClass "example-multi" runMulti
37runMulti :: forall t m. (SupportsServantReflex t m,
38 DomBuilder t m,
39 DomBuilderSpace m ~ GhcjsDomSpace,
40 MonadFix m,
41 PostBuild t m,
42 MonadHold t m) => m ()
43runMulti = do
44 url <- baseUrlWidget
45 el "br" blank
46 let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
47 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
49 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
50 num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
52 b <- button "Run dbl multi"
53 reqCount :: Dynamic t Int <- count b
54 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
55 dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
57 lastInd <- holdDyn [] $ fmap reqTag <$> r
58 display lastInd
60 divClass "demo-group" $ do
61 nms <- fmap (fmap T.words . value) $ divClass "" $ do
62 text "Names"
63 textInput def
64 grts <- fmap (fmap T.words . value) $ divClass "" $ do
65 text "Greetings"
66 textInput def
67 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
68 b <- button "Go"
69 r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)
71 dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
73 return ()
75run :: forall t m. (SupportsServantReflex t m,
76 DomBuilder t m,
77 DomBuilderSpace m ~ GhcjsDomSpace,
78 MonadFix m,
79 PostBuild t m,
80 MonadHold t m) => m ()
81run = mdo
83 reqCount <- count $ leftmost
84 [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
85 -- Allow user to choose the url target for the request
86 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
87 url <- baseUrlWidget
88 el "br" (return ())
89 dynText $ showBaseUrl <$> url
91 el "br" (return ())
93 -- Name the computed API client functions
94 let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
95 client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
97 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
99 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
100 unitBtn <- divClass "unit-button" $ button "Get unit"
101 intBtn <- divClass "int-button" $ button "Get int"
103 unitResponse <- getUnit $ tag (current reqCount) unitBtn
104 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
106 score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
108 r <- holdDyn "Waiting" $ fmap showXhrResponse $
109 leftmost [fmapMaybe response (unitResponse)
110 ,fmapMaybe response (intResponse)
111 ]
112 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
113 return (unitBtn, intBtn)
115 sayHiClicks <- elClass "div" "demo-group" $ do
117 text "Name"
118 el "br" $ return ()
119 inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
120 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
121 el "br" $ return ()
123 text "Greetings (space-separated)"
124 el "br" $ return ()
125 greetings <- fmap (fmap T.words . value) $
126 divClass "greetings-input" $ (textInput def)
128 el "br" $ return ()
130 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
132 el "br" $ return ()
133 sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
134 let triggers = leftmost [sayHiClicks, () <$ updated inp]
136 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
137 divClass "greeting-response" $ dynText =<<
138 holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
139 , fmapMaybe reqFailure (resp)])
140 return sayHiClicks
142 dblBtn <- elClass "div" "demo-group" $ do
143 text "A Double to double"
144 el "br" $ return ()
145 dblinp <- fmap value $ divClass "double-input" $ textInput def
146 (dblBtn) <- divClass "double-button" $ button "Double it"
147 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
148 dblinp) (tag (current reqCount) dblBtn)
149 divClass "double-errors" $ dynText =<<
150 holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
151 el "br" (return ())
152 divClass "double-result" $ el "p" $ dynText =<<
153 holdDyn "No number yet" (fmap tShow $
154 fmapMaybe reqSuccess (dblResp))
155 return dblBtn
157 mpGo <- elClass "div" "demo-group" $ do
158 text "Multi-part path"
159 b <- value <$> checkbox False def
160 mpGo <- button "Test"
161 multiResp <- multi b (tag (current reqCount) mpGo)
162 dynText =<< holdDyn "No res yet" (fmap tShow $
163 fmapMaybe reqSuccess $
164 (multiResp))
165 return mpGo
167 return ()
169 el "br" $ return ()
171 elClass "div" "demo-group" $ do
172 text "JSON Unicode encoding test"
173 txt <- value <$> textInput def
174 ev <- fmap (1 <$) $ button "Question"
175 let dQ = Right . Question <$> traceDyn "will send: " txt
176 rr <- qna dQ ev
177 el "p" $
178 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
180showXhrResponse :: XhrResponse -> Text
181showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
182 T.unlines ["stat: " <> tShow stat
183 ,"stattxt: " <> tShow stattxt
184 ,"resp: " <> maybe "" showRB rbmay
185 ,"rtext: " <> tShow rtmay
186 ,"rHeaders: " <> tShow respHeaders]
188tShow :: Show a => a -> Text
189tShow = T.pack . show
191showRB :: XhrResponseBody -> Text
192showRB (XhrResponseBody_Default t) = tShow t
193showRB (XhrResponseBody_Text t) = tShow t
194showRB (XhrResponseBody_Blob t) = "<Blob>"
195showRB (XhrResponseBody_ArrayBuffer t) = tShow t
197note :: e -> Maybe a -> Either e a
198note e = maybe (Left e) Right