git.iko.soy/typeable/servant-reflex
on tuple-api help sign in
typeable/servant-reflex/exec/Example.hs
130 lines 4.3 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7module Main where
9import Data.Bool
10import Data.Maybe
11import Control.Monad.Fix (MonadFix)
12import Data.Monoid ((<>))
13import Data.Text (Text)
14import qualified Data.Text as T
15import Servant.API
16import Servant.Reflex
17import API
18import Data.Proxy
19import Text.Read (readMaybe)
20import Reflex.Dom
22api :: Proxy API
23api = Proxy
25main :: IO ()
26main = mainWidget run
29run :: forall t m. (SupportsServantReflex t m,
30 DomBuilder t m,
31 DomBuilderSpace m ~ GhcjsDomSpace,
32 MonadFix m,
33 PostBuild t m,
34 MonadHold t m) => m ()
35run = do
37 -- Allow user to choose the url target for the request
38 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
39 url <- baseUrlWidget
40 el "br" (return ())
41 dynText $ showBaseUrl <$> url
42 el "br" (return ())
44 -- Name the computed API client functions
45 let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> doRaw) =
46 client api (Proxy :: Proxy m) url
48 elClass "div" "demo-group" $ do
49 unitBtn <- divClass "unit-button" $ button "Get unit"
50 intBtn <- divClass "int-button" $ button "Get int"
52 unitResponse <- getUnit unitBtn
53 intResponse :: Event t (ReqResult Int) <- getInt intBtn
55 score <- foldDyn (+) 0 (fmapMaybe reqSuccess intResponse)
57 r <- holdDyn "Waiting" $ fmap showXhrResponse $
58 leftmost [fmapMaybe response unitResponse
59 ,fmapMaybe response intResponse
60 ]
61 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
63 elClass "div" "demo-group" $ do
65 text "Name"
66 el "br" $ return ()
67 inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
68 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
69 el "br" $ return ()
71 text "Greetings (space-separated)"
72 el "br" $ return ()
73 greetings <- fmap (fmap T.words . value) $
74 divClass "greetings-input" $ (textInput def)
76 el "br" $ return ()
78 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
80 el "br" $ return ()
81 sayhiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
82 let triggers = leftmost [sayhiClicks, () <$ updated inp]
84 resp <- sayhi checkedName greetings gusto triggers
85 divClass "greeting-response" $ dynText =<<
86 holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess resp
87 , fmapMaybe reqFailure resp])
89 elClass "div" "demo-group" $ do
90 text "A Double to double"
91 el "br" $ return ()
92 dblinp <- fmap value $ divClass "double-input" $ textInput def
93 dblBtn <- divClass "double-button" $ button "Double it"
94 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
95 dblinp) dblBtn
96 divClass "double-errors" $ dynText =<<
97 holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
98 el "br" (return ())
99 divClass "double-result" $ el "p" $ dynText =<<
100 holdDyn "No number yet" (fmap tShow $
101 fmapMaybe reqSuccess dblResp)
103 elClass "div" "demo-group" $ do
104 text "Multi-part path"
105 b <- value <$> checkbox False def
106 mpGo <- button "Test"
107 multiResp <- multi b mpGo
108 dynText =<< holdDyn "No res yet" (fmap tShow $
109 fmapMaybe reqSuccess $
110 multiResp)
112showXhrResponse :: XhrResponse -> Text
113showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
114 T.unlines ["stat: " <> tShow stat
115 ,"stattxt: " <> tShow stattxt
116 ,"resp: " <> maybe "" showRB rbmay
117 ,"rtext: " <> tShow rtmay
118 ,"rHeaders: " <> tShow respHeaders]
120tShow :: Show a => a -> Text
121tShow = T.pack . show
123showRB :: XhrResponseBody -> Text
124showRB (XhrResponseBody_Default t) = tShow t
125showRB (XhrResponseBody_Text t) = tShow t
126showRB (XhrResponseBody_Blob t) = "<Blob>"
127showRB (XhrResponseBody_ArrayBuffer t) = tShow t
129note :: e -> Maybe a -> Either e a
130note e = maybe (Left e) Right