reflex-monad-auth-0.1.0.0: example/Main.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where

import Control.Monad.IO.Class
import Data.Functor
import Data.Map.Strict (Map)
import Data.Text (Text)
import Reflex.Auth
import Reflex.Dom
import Text.RawString.QQ

runAuthBool :: (Reflex t, TriggerEvent t m, MonadIO m) => AuthT Bool t m a -> m a
runAuthBool = runAuth

deriving instance DomBuilder t m => DomBuilder t (AuthT info t m)

main :: IO ()
main = mainWidgetWithCss css $ runAuthBool frontend
  where
    css = [r|
      .outline {
        border-width: 1px;
        border-radius: 10px;
        min-width: 100px;
        min-height: 50px;
        margin-right: 30px;
        color: black;
        background-color: white;
        border-color: black;
        font-size: 14pt;
      }
    |]

frontend :: (HasAuth t m, PerformEvent t m, TriggerEvent t m, MonadHold t m, DomBuilder t m, PostBuild t m, MonadIO m, MonadIO (Performable m), AuthInfo t m ~ Bool) => m ()
frontend = void $ liftAuth notlogged logged
  where
    notlogged = do
      pressE <- buttonClass "outline" "Login"
      widgetHold_ (pure ()) $ text "Logging in..." <$ pressE
      signE <- delay 1 pressE
      void $ signin (True <$ signE)
    logged = do
      pressE <- buttonClass "outline" "Logout"
      text "We are authorized!"
      void $ signout pressE

buttonClass :: (DomBuilder t m, PostBuild t m)
  => Dynamic t Text -> Dynamic t Text -> m (Event t ())
buttonClass classValD lbl = mkButton "button" [("onclick", "return false;")] classValD $ dynText lbl

mkButton :: (DomBuilder t m, PostBuild t m) => Text -> Map Text Text -> Dynamic t Text -> m a -> m (Event t a)
mkButton eltp attrs classValD ma = do
  let classesD = do
        classVal <- classValD
        pure $ attrs <> [("class", classVal)]
  (e, a) <- elDynAttr' eltp classesD ma
  return $ a <$ domEvent Click e