git.iko.soy/typeable/servant-reflex
on set-withCredentials help sign in
typeable/servant-reflex/exec/Example.hs
219 lines 7.9 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9module Main where
11------------------------------------------------------------------------------
12import Data.Bool
13import Data.Maybe
14import Control.Monad.Fix (MonadFix)
15import Data.Monoid (First(..), (<>))
16import Data.Text (Text)
17import qualified Data.Text as T
18import qualified Data.Text.Encoding as T
19import GHC.TypeLits
20import Servant.API
21import API
22import Data.Proxy
23import Text.Read (readMaybe)
24import Reflex.Dom hiding (run)
25------------------------------------------------------------------------------
26import Servant.Reflex
27import Servant.Reflex.Multi
30api :: Proxy API
31api = Proxy
33main :: IO ()
34main = mainWidget $ do
35 divClass "example-base" run
36 divClass "example-multi" runMulti
39runMulti :: forall t m. (SupportsServantReflex t m,
40 DomBuilder t m,
41 DomBuilderSpace m ~ GhcjsDomSpace,
42 MonadFix m,
43 PostBuild t m,
44 MonadHold t m) => m ()
45runMulti = do
46 url <- baseUrlWidget
47 el "br" blank
48 let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
49 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
51 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
52 num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
54 b <- button "Run dbl multi"
55 reqCount :: Dynamic t Int <- count b
56 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
57 dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
59 lastInd <- holdDyn [] $ fmap reqTag <$> r
60 display lastInd
62 divClass "demo-group" $ do
63 nms <- fmap (fmap T.words . value) $ divClass "" $ do
64 text "Names"
65 textInput def
66 grts <- fmap (fmap T.words . value) $ divClass "" $ do
67 text "Greetings"
68 textInput def
69 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
70 b <- button "Go"
71 r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
72 (constDyn [True, False]) (1 <$ b)
74 dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
75 fmap reqSuccess <$> r')
78 return ()
80run :: forall t m. (SupportsServantReflex t m,
81 DomBuilder t m,
82 DomBuilderSpace m ~ GhcjsDomSpace,
83 MonadFix m,
84 PostBuild t m,
85 MonadHold t m) => m ()
86run = mdo
88 reqCount <- count $ leftmost
89 [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
90 -- Allow user to choose the url target for the request
91 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
92 url <- baseUrlWidget
93 el "br" (return ())
94 dynText $ showBaseUrl <$> url
96 el "br" (return ())
98 -- Name the computed API client functions
99 let tweakRequest = ClientOptions $ \r -> do
100 putStrLn ("Got req: " ++ show r)
101 return $ r & withCredentials .~ True
102 let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103 :<|> multi :<|> qna :<|> secret :<|> doRaw) =
104 clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
108 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
109 unitBtn <- divClass "unit-button" $ button "Get unit"
110 intBtn <- divClass "int-button" $ button "Get int"
112 unitResponse <- getUnit $ tag (current reqCount) unitBtn
113 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
115 score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
117 r <- holdDyn "Waiting" $ fmap showXhrResponse $
118 leftmost [fmapMaybe response (unitResponse)
119 ,fmapMaybe response (intResponse)
120 ]
121 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
122 return (unitBtn, intBtn)
124 sayHiClicks <- elClass "div" "demo-group" $ do
126 text "Name"
127 el "br" $ return ()
128 inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
129 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
130 el "br" $ return ()
132 text "Greetings (space-separated)"
133 el "br" $ return ()
134 greetings <- fmap (fmap T.words . value) $
135 divClass "greetings-input" $ (textInput def)
137 el "br" $ return ()
139 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
141 el "br" $ return ()
142 sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
143 let triggers = leftmost [sayHiClicks, () <$ updated inp]
145 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
146 divClass "greeting-response" $ dynText =<<
147 holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
148 , fmapMaybe reqFailure (resp)])
149 return sayHiClicks
151 dblBtn <- elClass "div" "demo-group" $ do
152 text "A Double to double"
153 el "br" $ return ()
154 dblinp <- fmap value $ divClass "double-input" $ textInput def
155 (dblBtn) <- divClass "double-button" $ button "Double it"
156 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
157 dblinp) (tag (current reqCount) dblBtn)
158 divClass "double-errors" $ dynText =<<
159 holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
160 el "br" (return ())
161 divClass "double-result" $ el "p" $ dynText =<<
162 holdDyn "No number yet" (fmap tShow $
163 fmapMaybe reqSuccess (dblResp))
164 return dblBtn
166 mpGo <- elClass "div" "demo-group" $ do
167 text "Multi-part path"
168 b <- value <$> checkbox False def
169 mpGo <- button "Test"
170 multiResp <- multi b (tag (current reqCount) mpGo)
171 dynText =<< holdDyn "No res yet" (fmap tShow $
172 fmapMaybe reqSuccess $
173 (multiResp))
174 return mpGo
176 return ()
178 el "br" $ return ()
180 elClass "div" "demo-group" $ do
181 text "JSON Unicode encoding test"
182 txt <- value <$> textInput def
183 ev <- fmap (1 <$) $ button "Question"
184 let dQ = Right . Question <$> traceDyn "will send: " txt
185 rr <- qna dQ ev
186 el "p" $
187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
189 divClass "demo-group" $ do
190 un <- fmap value $ text "Username" >> textArea def
191 pw <- fmap value $ text "Unhidden PW" >> textArea def
192 let ba :: Dynamic t (BasicAuthData ) = BasicAuthData
193 <$> fmap T.encodeUtf8 un
194 <*> fmap T.encodeUtf8 pw
195 b <- button "Get secret"
196 r <- secret (Just <$> ba) (0 <$ b)
197 res <- holdDyn Nothing (reqSuccess <$> r)
198 display res
201showXhrResponse :: XhrResponse -> Text
202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
203 T.unlines ["stat: " <> tShow stat
204 ,"stattxt: " <> tShow stattxt
205 ,"resp: " <> maybe "" showRB rbmay
206 ,"rtext: " <> tShow rtmay
207 ,"rHeaders: " <> tShow respHeaders]
209tShow :: Show a => a -> Text
210tShow = T.pack . show
212showRB :: XhrResponseBody -> Text
213showRB (XhrResponseBody_Default t) = tShow t
214showRB (XhrResponseBody_Text t) = tShow t
215showRB (XhrResponseBody_Blob t) = "<Blob>"
216showRB (XhrResponseBody_ArrayBuffer t) = tShow t
218note :: e -> Maybe a -> Either e a
219note e = maybe (Left e) Right