git.iko.soy/typeable/servant-reflex
on auth-playing help sign in
typeable/servant-reflex/exec/Example.hs
201 lines 7.2 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 hiding (run)
23------------------------------------------------------------------------------
24import Servant.Reflex
25import Servant.Reflex.Multi
26import qualified TupleExample
29api :: Proxy API
30api = Proxy
32main :: IO ()
33main = mainWidget $ do
34 el "h1" $ text "Wowzers!"
35 divClass "example-base" run
36 divClass "example-multi" runMulti
37 divClass "example-tuple" TupleExample.run
40runMulti :: forall t m. (SupportsServantReflex t m,
41 DomBuilder t m,
42 DomBuilderSpace m ~ GhcjsDomSpace,
43 MonadFix m,
44 PostBuild t m,
45 MonadHold t m) => m ()
46runMulti = do
47 url <- baseUrlWidget
48 el "br" blank
49 let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
50 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
52 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
53 num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
55 b <- button "Run dbl multi"
56 reqCount :: Dynamic t Int <- count b
57 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
58 dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
60 lastInd <- holdDyn [] $ fmap reqTag <$> r
61 display lastInd
63 divClass "demo-group" $ do
64 nms <- fmap (fmap T.words . value) $ divClass "" $ do
65 text "Names"
66 textInput def
67 grts <- fmap (fmap T.words . value) $ divClass "" $ do
68 text "Greetings"
69 textInput def
70 gust <- fmap value $ divClass "gusto-input" $ checkbox False def
71 b <- button "Go"
72 r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) grts) (constDyn [True, False]) (1 <$ b)
74 dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
76 return ()
78run :: forall t m. (SupportsServantReflex t m,
79 DomBuilder t m,
80 DomBuilderSpace m ~ GhcjsDomSpace,
81 MonadFix m,
82 PostBuild t m,
83 MonadHold t m) => m ()
84run = mdo
86 reqCount <- count $ leftmost
87 [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
88 -- Allow user to choose the url target for the request
89 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
90 url <- baseUrlWidget
91 el "br" (return ())
92 dynText $ showBaseUrl <$> url
94 el "br" (return ())
96 -- Name the computed API client functions
97 let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
98 client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
100 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
102 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
103 unitBtn <- divClass "unit-button" $ button "Get unit"
104 intBtn <- divClass "int-button" $ button "Get int"
106 unitResponse <- getUnit $ tag (current reqCount) unitBtn
107 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
109 score <- foldDyn (+) 0 (fmapMaybe reqSuccess intResponse)
111 r <- holdDyn "Waiting" $ showXhrResponse <$>
112 leftmost [fmapMaybe response unitResponse
113 ,fmapMaybe response intResponse
114 ]
115 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
116 return (unitBtn, intBtn)
118 sayHiClicks <- elClass "div" "demo-group" $ do
120 text "Name"
121 el "br" $ return ()
122 inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ textInput def
123 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
124 el "br" $ return ()
126 text "Greetings (space-separated)"
127 el "br" $ return ()
128 greetings <- fmap (fmap T.words . value) $
129 divClass "greetings-input" $ textInput def
131 el "br" $ return ()
133 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
135 el "br" $ return ()
136 sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
137 let triggers = leftmost [sayHiClicks, () <$ updated inp]
139 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
140 divClass "greeting-response" $ dynText =<<
141 holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess resp
142 , fmapMaybe reqFailure resp])
143 return sayHiClicks
145 dblBtn <- elClass "div" "demo-group" $ do
146 text "A Double to double"
147 el "br" $ return ()
148 dblinp <- fmap value $ divClass "double-input" $ textInput def
149 dblBtn <- divClass "double-button" $ button "Double it"
150 dblResp <- dbl ((note "read failure" . readMaybe . T.unpack) <$>
151 dblinp) (tag (current reqCount) dblBtn)
152 divClass "double-errors" $ dynText =<<
153 holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
154 el "br" (return ())
155 divClass "double-result" $ el "p" $ dynText =<<
156 holdDyn "No number yet" (tShow <$>
157 fmapMaybe reqSuccess dblResp)
158 return dblBtn
160 mpGo <- elClass "div" "demo-group" $ do
161 text "Multi-part path"
162 b <- value <$> checkbox False def
163 mpGo <- button "Test"
164 multiResp <- multi b (tag (current reqCount) mpGo)
165 dynText =<< holdDyn "No res yet" (tShow <$>
166 fmapMaybe reqSuccess
167 multiResp)
168 return mpGo
170 return ()
172 el "br" $ return ()
174 elClass "div" "demo-group" $ do
175 text "JSON Unicode encoding test"
176 txt <- value <$> textInput def
177 ev <- (1 <$) <$> button "Question"
178 let dQ = Right . Question <$> traceDyn "will send: " txt
179 rr <- qna dQ ev
180 el "p" $
181 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
183showXhrResponse :: XhrResponse -> Text
184showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
185 T.unlines ["stat: " <> tShow stat
186 ,"stattxt: " <> tShow stattxt
187 ,"resp: " <> maybe "" showRB rbmay
188 ,"rtext: " <> tShow rtmay
189 ,"rHeaders: " <> tShow respHeaders]
191tShow :: Show a => a -> Text
192tShow = T.pack . show
194showRB :: XhrResponseBody -> Text
195showRB (XhrResponseBody_Default t) = tShow t
196showRB (XhrResponseBody_Text t) = tShow t
197showRB (XhrResponseBody_Blob t) = "<Blob>"
198showRB (XhrResponseBody_ArrayBuffer t) = tShow t
200note :: e -> Maybe a -> Either e a
201note e = maybe (Left e) Right