Reflex request example

README.md

To start the server

$ ghcjs --make app.hs
$ chmod +x server.hs
$ ./server.hs
$ open "http://localhost:9000/static/index.html"

app.hs

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, TemplateHaskell, RecursiveDo #-}
-----------------------
-- | ghcjs --make app.hs
import           Reflex.Dom
import           Data.Default
import           Reflex
import           Data.Maybe
import qualified Data.Aeson as Aeson
import qualified Data.Map as Map
import qualified Data.Text as T
import           Data.Aeson.TH
import           Control.Monad.IO.Class

--forgive the hokey code duplication instead of splitting the datatype into a 3rd file/module
data Account = Account {
  _username :: !String
, _email :: !(Maybe String)
} deriving (Eq, Show, Read, Ord)

$(deriveJSON defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1} ''Account)

defaultacct :: Account
defaultacct = Account "default" Nothing

load :: MonadWidget t m => m (Event t Account)
load = do
  let req = xhrRequest "GET" "http://localhost:9000/acct" def
  pb <- getPostBuild
  asyncReq <- performRequestAsync (tag (constant req) pb)
  return $ fmap (fromMaybe defaultacct. decodeXhrResponse) asyncReq

flipAcct :: Account -> Account -> Account
flipAcct (Account "default" _) _ = Account "receieved default" Nothing
flipAcct (Account "spj" _) _ = Account "received spj" Nothing
flipAcct _ _ = Account "impossible" Nothing

acctBtn' :: MonadWidget t m => Account -> m ()
acctBtn' aresp = mdo
  let noOp = ("href" =: "javascript:void(0)") -- no-op button
  dynAccount <- foldDyn flipAcct aresp $ fmap (const defaultacct) (_el_clicked linkbtn)
  (linkbtn, _) <- elAttr' "a" noOp $ display dynAccount
  return ()

main :: IO ()
main = mainWidget $ do
  eacct <- load
  widgetHold (text "loading") (fmap acctBtn' eacct)
  return ()

server.hs

#!/usr/bin/env stack
-- stack --resolver lts-2.19 --install-ghc runghc --package yesod
{-# LANGUAGE OverloadedStrings, QuasiQuotes, RecordWildCards, TemplateHaskell, ViewPatterns, TypeFamilies, ScopedTypeVariables #-}
import           Control.Applicative
import           Yesod
import           Yesod.Static
import qualified Data.Text as Text
import           Data.Text (Text)
import           Data.Aeson.TH
-- import           Control.Concurrent

data Account = Account {
  _username :: !String
, _email :: !(Maybe String)
} deriving (Eq, Show, Read, Ord)

$(deriveJSON defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1} ''Account)

data App = App {
  getStatic :: Static
}

mkYesod "App" [parseRoutes|
/acct AcctR GET POST
/static StaticR Static getStatic
|]

instance Yesod App

getAcctR :: Handler Value
getAcctR = do
  -- liftIO $ threadDelay (1000000 * 2)
  returnJson $ Account "spj" (pure "a@b.c")

postAcctR :: Handler Text
postAcctR = do
  config :: Account <- requireJsonBody
  liftIO $ print config
  return "You posted!"

main :: IO()
main = do
  s <- staticDevel "app.jsexe/"
  warp 9000 $ App s