{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
------------------------------------------------------------------------------
import Data.Bool
import Data.Maybe
import Control.Monad.Fix (MonadFix)
import Data.Monoid (First(..), (<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.TypeLits
import Servant.API
import API
import Data.Proxy
import Text.Read (readMaybe)
import Reflex.Dom.Core hiding (run)
------------------------------------------------------------------------------
import Servant.Reflex
import Servant.Reflex.Multi
api :: Proxy API
api = Proxy
main :: IO ()
main = mainWidget $ do
divClass "example-base" run
divClass "example-multi" runMulti
runMulti :: forall t m. (SupportsServantReflex t m,
DomBuilder t m,
DomBuilderSpace m ~ GhcjsDomSpace,
MonadFix m,
PostBuild t m,
MonadHold t m) => m ()
runMulti = do
url <- baseUrlWidget
el "br" blank
let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
b <- button "Run dbl multi"
reqCount :: Dynamic t Int <- count b
r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
lastInd <- holdDyn [] $ fmap reqTag <$> r
display lastInd
divClass "demo-group" $ do
nms <- fmap (fmap T.words . value) $ divClass "" $ do
text "Names"
textInput def
grts <- fmap (fmap T.words . value) $ divClass "" $ do
text "Greetings"
textInput def
gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
b <- button "Go"
r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
(constDyn [True, False]) (1 <$ b)
dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
fmap reqSuccess <$> r')
return ()
run :: forall t m. (SupportsServantReflex t m,
DomBuilder t m,
DomBuilderSpace m ~ GhcjsDomSpace,
MonadFix m,
PostBuild t m,
MonadHold t m) => m ()
run = mdo
reqCount <- count $ leftmost
[() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
-- Allow user to choose the url target for the request
-- (alternatively we could just `let url = constDyn (BasePath "/")`)
url <- baseUrlWidget
el "br" (return ())
dynText $ showBaseUrl <$> url
el "br" (return ())
-- Name the computed API client functions
let tweakRequest = ClientOptions $ \r -> do
return $ r & withCredentials .~ True
let (getUnit :<|> getInt :<|> sayhi :<|> dbl
:<|> multi :<|> qna :<|> secret :<|> doRaw) =
clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
(unitBtn, intBtn) <- elClass "div" "demo-group" $ do
unitBtn <- divClass "unit-button" $ button "Get unit"
intBtn <- divClass "int-button" $ button "Get int"
unitResponse <- getUnit $ tag (current reqCount) unitBtn
intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
r <- holdDyn "Waiting" $ fmap showXhrResponse $
leftmost [fmapMaybe response (unitResponse)
,fmapMaybe response (intResponse)
]
divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
return (unitBtn, intBtn)
sayHiClicks <- elClass "div" "demo-group" $ do
text "Name"
el "br" $ return ()
inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
el "br" $ return ()
text "Greetings (space-separated)"
el "br" $ return ()
greetings <- fmap (fmap T.words . value) $
divClass "greetings-input" $ (textInput def)
el "br" $ return ()
gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
el "br" $ return ()
sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
let triggers = leftmost [sayHiClicks, () <$ updated inp]
resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
divClass "greeting-response" $ dynText =<<
holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
, fmapMaybe reqFailure (resp)])
return sayHiClicks
dblBtn <- elClass "div" "demo-group" $ do
text "A Double to double"
el "br" $ return ()
dblinp <- fmap value $ divClass "double-input" $ textInput def
(dblBtn) <- divClass "double-button" $ button "Double it"
dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
dblinp) (tag (current reqCount) dblBtn)
divClass "double-errors" $ dynText =<<
holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
el "br" (return ())
divClass "double-result" $ el "p" $ dynText =<<
holdDyn "No number yet" (fmap tShow $
fmapMaybe reqSuccess (dblResp))
return dblBtn
mpGo <- elClass "div" "demo-group" $ do
text "Multi-part path"
b <- value <$> checkbox False def
mpGo <- button "Test"
multiResp <- multi b (tag (current reqCount) mpGo)
dynText =<< holdDyn "No res yet" (fmap tShow $
fmapMaybe reqSuccess $
(multiResp))
return mpGo
return ()
el "br" $ return ()
elClass "div" "demo-group" $ do
text "JSON Unicode encoding test"
txt <- value <$> textInput def
ev <- fmap (1 <$) $ button "Question"
let dQ = Right . Question <$> traceDyn "will send: " txt
rr <- qna dQ ev
el "p" $
dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
divClass "demo-group" $ do
un <- fmap value $ text "Username" >> textArea def
pw <- fmap value $ text "Unhidden PW" >> textArea def
let ba :: Dynamic t (BasicAuthData ) = BasicAuthData
<$> fmap T.encodeUtf8 un
<*> fmap T.encodeUtf8 pw
b <- button "Get secret"
r <- secret (Just <$> ba) (0 <$ b)
res <- holdDyn Nothing (reqSuccess <$> r)
display res
showXhrResponse :: XhrResponse -> Text
showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
T.unlines ["stat: " <> tShow stat
,"stattxt: " <> tShow stattxt
,"resp: " <> maybe "" showRB rbmay
,"rtext: " <> tShow rtmay
,"rHeaders: " <> tShow respHeaders]
tShow :: Show a => a -> Text
tShow = T.pack . show
showRB :: XhrResponseBody -> Text
showRB (XhrResponseBody_Default t) = tShow t
showRB (XhrResponseBody_Text t) = tShow t
showRB (XhrResponseBody_Blob t) = "<Blob>"
showRB (XhrResponseBody_ArrayBuffer t) = tShow t
note :: e -> Maybe a -> Either e a
note e = maybe (Left e) Right