git.iko.soy/servant-reflex
on develop help sign in
servant-reflex/exec/Example.hs
121 lines 3.8 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 <- button "Get unit"
50 intBtn <- 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 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 (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) (textInput def)
75 el "br" $ return ()
77 gusto <- value <$> checkbox False def
79 el "br" $ return ()
80 sayhiClicks :: Event t () <- button "Say hi"
81 let triggers = leftmost [sayhiClicks, () <$ updated inp]
83 resp <- sayhi checkedName greetings gusto triggers
84 dynText =<< holdDyn "No hi yet" (leftmost [fmapMaybe reqSuccess resp, fmapMaybe reqFailure resp])
86 elClass "div" "demo-group" $ do
87 text "A Double to double"
88 el "br" $ return ()
89 dblinp <- value <$> textInput def
90 dblBtn <- button "Double it"
91 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $ dblinp) dblBtn
92 dynText =<< holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
93 el "br" (return ())
94 display =<< holdDyn "No number yet" (fmap tShow $ fmapMaybe reqSuccess dblResp)
96 elClass "div" "demo-group" $ do
97 text "Multi-part path"
98 b <- value <$> checkbox False def
99 mpGo <- button "Test"
100 multiResp <- multi b mpGo
101 dynText =<< holdDyn "No res yet" (fmap tShow $ fmapMaybe reqSuccess $ multiResp)
103showXhrResponse :: XhrResponse -> Text
104showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
105 T.unlines ["stat: " <> tShow stat
106 ,"stattxt: " <> tShow stattxt
107 ,"resp: " <> maybe "" showRB rbmay
108 ,"rtext: " <> tShow rtmay
109 ,"rHeaders: " <> tShow respHeaders]
111tShow :: Show a => a -> Text
112tShow = T.pack . show
114showRB :: XhrResponseBody -> Text
115showRB (XhrResponseBody_Default t) = tShow t
116showRB (XhrResponseBody_Text t) = tShow t
117showRB (XhrResponseBody_Blob t) = "<Blob>"
118showRB (XhrResponseBody_ArrayBuffer t) = tShow t
120note :: e -> Maybe a -> Either e a
121note e = maybe (Left e) Right