669 lines
19 KiB
Plaintext
669 lines
19 KiB
Plaintext
{-
|
|
|
|
This Gist has:
|
|
* PushState routing
|
|
* Interception of all clicks on <a> hrefs or their children
|
|
* Login / sign out
|
|
- You "land" on the 'Secrets' page, but cannot see it until you "Login"
|
|
|
|
You can preview the appearance of this Gist on TryPureScript, but note
|
|
that the PushState routing will not work within its <iframe> environment
|
|
|
|
-}
|
|
|
|
module Main where
|
|
|
|
import Prelude hiding ((/))
|
|
|
|
import Control.Alt ((<|>))
|
|
import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
|
|
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
|
|
import Control.Monad.Rec.Class as Rec
|
|
import Control.Monad.State (class MonadState)
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Data.Array as Array
|
|
import Data.Bifunctor (lmap)
|
|
import Data.Const (Const)
|
|
import Data.Either (Either(..), either, note)
|
|
import Data.Generic.Rep (class Generic)
|
|
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
|
|
import Data.Show.Generic (genericShow)
|
|
import Data.String as String
|
|
import Effect (Effect)
|
|
import Effect.Aff (Aff, launchAff_)
|
|
import Effect.Aff as Aff
|
|
import Effect.Aff.Class (class MonadAff)
|
|
import Effect.Class (class MonadEffect)
|
|
import Foreign as F
|
|
import Halogen as H
|
|
import Halogen.Aff as HA
|
|
import Halogen.HTML as HH
|
|
import Halogen.HTML.Events as HE
|
|
import Halogen.HTML.Properties as HP
|
|
import Halogen.Store.Connect as HSC
|
|
import Halogen.Store.Monad as HSM
|
|
import Halogen.Store.Select as HSS
|
|
import Halogen.VDom.Driver ( runUI )
|
|
import Routing.Duplex (RouteDuplex')
|
|
import Routing.Duplex as RD
|
|
import Routing.Duplex.Generic ( noArgs, sum )
|
|
import Routing.Duplex.Generic.Syntax ((/))
|
|
import Routing.Duplex.Parser (RouteError)
|
|
import Routing.PushState as RPS
|
|
import Type.Proxy (Proxy(Proxy))
|
|
import Web.DOM.Document as Document
|
|
import Web.DOM.Element as Element
|
|
import Web.DOM.Node as Node
|
|
import Web.DOM.ParentNode (QuerySelector(..))
|
|
import Web.DOM.Text as Text
|
|
import Web.Event.Event (Event)
|
|
import Web.Event.Event as Event
|
|
import Web.Event.EventTarget (EventTarget)
|
|
import Web.HTML as HTML
|
|
import Web.HTML.HTMLAnchorElement (HTMLAnchorElement)
|
|
import Web.HTML.HTMLAnchorElement as HTMLAnchorElement
|
|
import Web.HTML.HTMLElement (HTMLElement)
|
|
import Web.HTML.HTMLElement as HTMLElement
|
|
import Web.HTML.HTMLHyperlinkElementUtils as Utils
|
|
import Web.HTML.Location as Location
|
|
import Web.HTML.Window as Window
|
|
import Web.UIEvent.MouseEvent as MouseEvent
|
|
|
|
----------
|
|
-- `Main`
|
|
|
|
main :: Effect Unit
|
|
main = HA.runHalogenAff do
|
|
|
|
HA.awaitLoad
|
|
|
|
let
|
|
selectHTML :: String -> ExceptT String Aff HTMLElement
|
|
selectHTML target = ExceptT do
|
|
maybeElement <- HA.selectElement (QuerySelector target)
|
|
pure $ maybe (Left ("'" <> target <> "' element not found")) Right maybeElement
|
|
|
|
either (throwError <<< Aff.error) pure =<< runExceptT do
|
|
|
|
html <- selectHTML "html"
|
|
body <- selectHTML "body"
|
|
H.liftEffect $ Node.removeChild (HTMLElement.toNode body) (HTMLElement.toNode html)
|
|
|
|
-- This section is to to add a stylesheet (see bottom of Gist) to the header
|
|
-- within a TryPureScript <iframe>, as I use the site a lot for small demos.
|
|
headNode <- HTMLElement.toNode <$> selectHTML "head"
|
|
doc <- ExceptT $ map (note "document not found") do
|
|
H.liftEffect $ Node.ownerDocument headNode
|
|
H.liftEffect do
|
|
styleElem <- Element.toNode <$> Document.createElement "style" doc
|
|
styleTextNode <- Text.toNode <$> Document.createTextNode stylesheet doc
|
|
Node.appendChild styleTextNode styleElem *> Node.appendChild styleElem headNode
|
|
|
|
nav <- H.liftEffect RPS.makeInterface
|
|
|
|
let
|
|
initialStore :: Store
|
|
initialStore = { currentUser: Nothing, loggerHist: [], nav }
|
|
|
|
routerInput :: Unit
|
|
routerInput = unit
|
|
|
|
lift do
|
|
componentAff <- runAppM initialStore componentRouter
|
|
halogenIO <- runUI componentAff routerInput html
|
|
|
|
void $ H.liftEffect $ nav # RPS.matchesWith routeParse \maybeOld new ->
|
|
when ( maybeOld /= Just new ) $
|
|
launchAff_ do
|
|
void $ halogenIO.query $ H.mkTell $ Router_Navigate new
|
|
|
|
|
|
-- Store: App-wide state
|
|
|
|
type Store =
|
|
{ currentUser :: Maybe Profile
|
|
, loggerHist :: Array String
|
|
, nav :: RPS.PushStateInterface
|
|
}
|
|
|
|
data StoreAction
|
|
= LoginUser Profile
|
|
| LogoutUser
|
|
| UpdateHistory String
|
|
|
|
reduce :: Store -> StoreAction -> Store
|
|
reduce store = case _ of
|
|
LoginUser profile ->
|
|
store { currentUser = Just profile }
|
|
|
|
LogoutUser ->
|
|
store { currentUser = Nothing }
|
|
|
|
UpdateHistory msg ->
|
|
store { loggerHist = msg `prependMessage` store.loggerHist }
|
|
where
|
|
prependMessage :: String -> Array String -> Array String
|
|
prependMessage x xs
|
|
| Array.length xs < 10 = x `Array.cons` xs
|
|
| otherwise = x `Array.cons` (Array.take 9 xs)
|
|
|
|
|
|
updateLocalState
|
|
:: forall m r i
|
|
. MonadState { currentUser :: Maybe Profile | r } m
|
|
=> { context :: Maybe Profile | i }
|
|
-> m Unit
|
|
updateLocalState { context: newUser } = do
|
|
oldUser <- H.gets _.currentUser
|
|
when (oldUser /= newUser) do
|
|
H.modify_ _ { currentUser = newUser }
|
|
|
|
|
|
-- | AppM: Main application Monad
|
|
|
|
newtype AppM a = AppM (HSM.StoreT StoreAction Store Aff a)
|
|
|
|
runAppM :: forall q i o. Store -> H.Component q i o AppM -> Aff (H.Component q i o Aff)
|
|
runAppM initialStore = HSM.runStoreT initialStore reduce <<< H.hoist (\(AppM m) -> m )
|
|
|
|
derive newtype instance Functor AppM
|
|
derive newtype instance Apply AppM
|
|
derive newtype instance Applicative AppM
|
|
derive newtype instance Bind AppM
|
|
derive newtype instance Monad AppM
|
|
derive newtype instance MonadEffect AppM
|
|
derive newtype instance MonadAff AppM
|
|
derive newtype instance HSM.MonadStore StoreAction Store AppM
|
|
|
|
instance MonadNavigate AppM where
|
|
navigate :: Route -> AppM Unit
|
|
navigate r = do
|
|
{ nav } <- HSM.getStore
|
|
H.liftEffect $ nav.pushState (F.unsafeToForeign {}) (routePrint r)
|
|
|
|
logoutUser :: AppM Unit
|
|
logoutUser = do
|
|
HSM.updateStore LogoutUser
|
|
navigate Home
|
|
|
|
instance MonadUser AppM where
|
|
loginUser :: Username -> AppM (Maybe Profile)
|
|
loginUser username = do
|
|
HSM.updateStore $ LoginUser { username }
|
|
pure (Just { username })
|
|
|
|
instance MonadLog AppM where
|
|
log :: String -> AppM Unit
|
|
log msg = do
|
|
HSM.updateStore $ UpdateHistory msg
|
|
|
|
|
|
-- Capability classes
|
|
|
|
class Monad m <= MonadNavigate m where
|
|
navigate :: Route -> m Unit
|
|
logoutUser :: m Unit
|
|
|
|
instance MonadNavigate m => MonadNavigate ( H.HalogenM state action slots msg m ) where
|
|
navigate = H.lift <<< navigate
|
|
logoutUser = H.lift logoutUser
|
|
|
|
class Monad m <= MonadUser m where
|
|
loginUser :: Username -> m (Maybe Profile)
|
|
|
|
instance MonadUser m => MonadUser ( H.HalogenM state action slots msg m ) where
|
|
loginUser = H.lift <<< loginUser
|
|
|
|
class Monad m <= MonadLog m where
|
|
log :: String -> m Unit
|
|
|
|
instance MonadLog m => MonadLog ( H.HalogenM state action slots msg m ) where
|
|
log = H.lift <<< log
|
|
|
|
|
|
-- Data.Route
|
|
|
|
data Route
|
|
= Home
|
|
| Secrets
|
|
|
|
derive instance Generic Route _
|
|
derive instance Eq Route
|
|
derive instance Ord Route
|
|
instance Show Route where show = genericShow
|
|
|
|
routePrint :: Route -> String
|
|
routePrint = RD.print codec
|
|
|
|
routeParse :: String -> Either String Route
|
|
routeParse = lmap show <<< RD.parse codec
|
|
|
|
codec :: RouteDuplex' Route
|
|
codec = RD.root $ sum
|
|
{ "Home": noArgs
|
|
, "Secrets": "secrets" / noArgs
|
|
}
|
|
|
|
|
|
-- Data.Profile
|
|
|
|
type Profile = { username :: Username }
|
|
|
|
type Username = String
|
|
|
|
parseUsername :: String -> Maybe Username
|
|
parseUsername = case _ of
|
|
"" -> Nothing
|
|
str -> Just str
|
|
|
|
printUsername :: Username -> String
|
|
printUsername u = u
|
|
|
|
|
|
-- Component.Router
|
|
data Router_Query :: Type -> Type
|
|
data Router_Query a = Router_Navigate Route a
|
|
|
|
type ConnectedInput = HSC.Connected (Maybe Profile) Unit
|
|
|
|
type Router_State =
|
|
{ route :: Maybe Route
|
|
, loggerHist :: Array String
|
|
, currentUser :: Maybe Profile
|
|
}
|
|
|
|
data Router_Action
|
|
= Router_Initialize
|
|
| Router_Receive { input :: Unit, context :: (Maybe Profile) }
|
|
| Router_AnchorClick Event
|
|
| Router_LogMsg (Array String)
|
|
|
|
type Router_ChildSlots =
|
|
( home :: Home_Slot
|
|
, secrets :: Secrets_Slot
|
|
)
|
|
|
|
type RouterM = H.HalogenM Router_State Router_Action Router_ChildSlots Void AppM
|
|
type RouterHTML = H.ComponentHTML Router_Action Router_ChildSlots AppM
|
|
|
|
componentRouter :: H.Component Router_Query Unit Void AppM
|
|
componentRouter =
|
|
HSC.connect (HSS.selectEq _.currentUser) $
|
|
H.mkComponent { initialState, render, eval }
|
|
where
|
|
eval :: H.HalogenQ _ _ _ ~> H.HalogenM _ _ _ _ _
|
|
eval = H.mkEval $ H.defaultEval
|
|
{ handleAction = handleAction
|
|
, handleQuery = handleQuery
|
|
, initialize = Just Router_Initialize
|
|
, receive = Just <<< Router_Receive
|
|
}
|
|
|
|
initialState :: ConnectedInput -> Router_State
|
|
initialState = \{ context: currentUser } ->
|
|
{ route: Just Secrets
|
|
, loggerHist: []
|
|
, currentUser
|
|
}
|
|
|
|
handleAction
|
|
:: Router_Action
|
|
-> RouterM Unit
|
|
handleAction = case _ of
|
|
Router_Initialize -> do
|
|
HSM.getStore >>= \r -> H.modify_ _ { loggerHist = r.loggerHist }
|
|
loggerHistEmitter <- HSM.emitSelected (HSS.selectEq _.loggerHist)
|
|
void $ H.subscribe (Router_LogMsg <$> loggerHistEmitter)
|
|
|
|
Router_Receive input ->
|
|
updateLocalState input
|
|
|
|
Router_AnchorClick event -> do
|
|
withClickedAnchor_ event codec case _ of
|
|
LocalRoute route -> do
|
|
H.liftEffect $ Event.preventDefault event
|
|
log $ "Local anchor link clicked for route: " <> show route
|
|
navigate route
|
|
|
|
LocalRouteError { anchorPath: path, routeError: _ } -> do
|
|
log $ "Local anchor link clicked for route that fails to parse: " <> show path
|
|
H.liftEffect $ Event.preventDefault event
|
|
|
|
ForeignRoute { anchorHost: host, anchorHref: _ } -> do
|
|
log $ "Anchor clicked for link to foreign host: " <> show host <> " (not exiting)"
|
|
H.liftEffect $ Event.preventDefault event
|
|
|
|
Router_LogMsg newLog -> do
|
|
currentLog <- H.gets _.loggerHist
|
|
when (newLog /= currentLog) do
|
|
H.modify_ _ { loggerHist = newLog }
|
|
|
|
handleQuery :: forall a. Router_Query a -> RouterM ( Maybe a )
|
|
handleQuery = case _ of
|
|
Router_Navigate new a -> do
|
|
{ currentUser: _, route: maybeOld } <- H.get
|
|
|
|
when (maybeOld /= Just new) do
|
|
H.modify_ _ { route = Just new }
|
|
log $ displayRouteChange maybeOld new
|
|
|
|
pure ( Just a )
|
|
|
|
where
|
|
labelFromMain txt = "[ main | matchesWith | Address bar path ] " <> txt
|
|
|
|
labelNavigate txt = "[ Router | Query = Navigate ] " <> txt
|
|
|
|
displayRouteChange :: Maybe Route -> Route -> String
|
|
displayRouteChange maybeOld new =
|
|
String.joinWith "\n"
|
|
[ labelFromMain $ case maybeOld of
|
|
Nothing -> "was set on load to " <> routePrint new
|
|
Just old -> "was set from " <> routePrint old <> " to " <> routePrint new
|
|
, labelNavigate $ case maybeOld of
|
|
Nothing -> "Setting local state initially to " <> show new
|
|
Just old -> "Setting local state from " <> show old <> " to " <> show new
|
|
]
|
|
|
|
render :: Router_State -> RouterHTML
|
|
render st@{ currentUser } =
|
|
HH.body
|
|
[ css ("body "<>""), HE.onClick (Router_AnchorClick <<< MouseEvent.toEvent) ]
|
|
[ HH.nav
|
|
[ css "nav" ]
|
|
[ HH.ul
|
|
[ css "nav-ul" ]
|
|
[ renderNavItem Home "🏡" "Home"
|
|
, whenElem (isJust currentUser) \_ ->
|
|
renderNavItem Secrets "🕵" "Secrets"
|
|
]
|
|
]
|
|
, HH.main [ css "main" ]
|
|
[ renderChildren st
|
|
, HH.hr_
|
|
, HH.div [ css "logger" ]
|
|
[ HH.h2_ [ HH.text "Logger Output:" ]
|
|
, HH.ul_ (map (\x -> HH.li_ [ HH.text x ]) st.loggerHist)
|
|
]
|
|
]
|
|
]
|
|
|
|
renderNavItem :: forall w i. Route -> String -> String -> HH.HTML w i
|
|
renderNavItem r i label =
|
|
HH.li
|
|
[ css "nav-li" ]
|
|
[ HH.text i
|
|
, HH.a
|
|
[ safeHref r, HP.style "margin-left: 0.25rem;" ]
|
|
[ HH.text label ]
|
|
]
|
|
|
|
renderChildren :: Router_State -> RouterHTML
|
|
renderChildren = case _ of
|
|
{ route: Nothing } ->
|
|
HH.slot_ (Proxy :: _ "home") unit componentHome unit
|
|
|
|
{ route: Just Home } ->
|
|
HH.slot_ (Proxy :: _ "home") unit componentHome unit
|
|
|
|
{ currentUser, route: Just Secrets } ->
|
|
authorize currentUser do
|
|
HH.slot_ (Proxy :: _ "secrets") unit componentSecrets unit
|
|
|
|
where
|
|
authorize :: Maybe Profile -> HH.HTML _ _ -> HH.HTML _ _
|
|
authorize mProfile html = case mProfile of
|
|
Nothing -> HH.slot_ (Proxy :: _ "home") unit componentHome unit
|
|
Just _ -> html
|
|
|
|
|
|
data AnchorClickResult
|
|
= LocalRoute Route
|
|
| LocalRouteError { anchorPath :: String, routeError :: RouteError }
|
|
| ForeignRoute { anchorHost :: String, anchorHref :: String }
|
|
|
|
withClickedAnchor_
|
|
:: Event
|
|
-> RouteDuplex' Route
|
|
-> (AnchorClickResult -> RouterM Unit)
|
|
-> RouterM Unit
|
|
withClickedAnchor_ event codec' parsedRouteAction =
|
|
void $ runMaybeT do
|
|
target <- hoistMaybe $ Event.target event
|
|
anchor <- getAnchorIfTarget target <|> walkupDomToAnchor target
|
|
let
|
|
utils = HTMLAnchorElement.toHTMLHyperlinkElementUtils anchor
|
|
siteHost <- H.liftEffect $ Location.host =<< Window.location =<< HTML.window
|
|
anchorHost <- H.liftEffect $ Utils.host utils
|
|
anchorPath <- H.liftEffect $ Utils.pathname utils
|
|
case RD.parse codec' anchorPath of
|
|
Left routeError ->
|
|
lift $ parsedRouteAction $ LocalRouteError { anchorPath, routeError }
|
|
Right localRoute
|
|
| siteHost == anchorHost -> do
|
|
lift $ parsedRouteAction $ LocalRoute localRoute
|
|
| otherwise -> do
|
|
anchorHref <- H.liftEffect $ Utils.href utils
|
|
lift $ parsedRouteAction $ ForeignRoute { anchorHost, anchorHref }
|
|
where
|
|
getAnchorIfTarget :: EventTarget -> MaybeT RouterM HTMLAnchorElement
|
|
getAnchorIfTarget eventTarget =
|
|
hoistMaybe (HTMLAnchorElement.fromEventTarget eventTarget)
|
|
|
|
walkupDomToAnchor :: EventTarget -> MaybeT RouterM HTMLAnchorElement
|
|
walkupDomToAnchor eventTarget = do
|
|
targetElement <- hoistMaybe $ Element.fromEventTarget eventTarget
|
|
targetElement # Rec.tailRecM \currentElement ->
|
|
case HTMLAnchorElement.fromElement currentElement of
|
|
Nothing -> do
|
|
parent <- MaybeT $ H.liftEffect $ Node.parentElement (Element.toNode currentElement)
|
|
pure $ Rec.Loop parent
|
|
Just anchor -> do
|
|
pure $ Rec.Done anchor
|
|
|
|
|
|
hoistMaybe :: forall m a. Monad m => Maybe a -> MaybeT m a
|
|
hoistMaybe = MaybeT <<< pure
|
|
|
|
-- Component.HTML.Util
|
|
|
|
css :: forall r i. String -> HH.IProp ( class :: String | r ) i
|
|
css = HP.class_ <<< HH.ClassName
|
|
|
|
safeHref :: forall r i. Route -> HH.IProp ( href :: String | r) i
|
|
safeHref = HP.href <<< routePrint
|
|
|
|
whenElem :: forall w i. Boolean -> (Unit -> HH.HTML w i) -> HH.HTML w i
|
|
whenElem cond f = if cond then f unit else HH.text ""
|
|
|
|
maybeElem :: forall w i a. Maybe a -> (a -> HH.HTML w i) -> HH.HTML w i
|
|
maybeElem (Just x) f = f x
|
|
maybeElem _ _ = HH.text ""
|
|
|
|
----------
|
|
-- Page.Home
|
|
-- (visible to both logged-in/-out users)
|
|
|
|
type Home_State =
|
|
{ currentUser :: Maybe Profile
|
|
}
|
|
|
|
data Home_Action
|
|
= Home_Initialize
|
|
| Home_Receive { context :: Maybe Profile, input :: Unit }
|
|
| Home_Login Event
|
|
|
|
type Home_Slot = H.Slot (Const Void) Void Unit
|
|
|
|
type HomeM = H.HalogenM Home_State Home_Action () Void AppM
|
|
type HomeHTML = H.ComponentHTML Home_Action () AppM
|
|
|
|
componentHome :: H.Component (Const Void) Unit Void AppM
|
|
componentHome =
|
|
HSC.connect (HSS.selectEq _.currentUser) $
|
|
H.mkComponent { initialState, render, eval }
|
|
where
|
|
initialState :: ConnectedInput -> Home_State
|
|
initialState =
|
|
\{ context: currentUser } ->
|
|
{ currentUser
|
|
}
|
|
|
|
eval = H.mkEval H.defaultEval
|
|
{ handleAction = handleAction
|
|
, initialize = Just Home_Initialize
|
|
, receive = Just <<< Home_Receive
|
|
}
|
|
|
|
render :: Home_State -> HomeHTML
|
|
render { currentUser } =
|
|
HH.div
|
|
[ css "page" ]
|
|
[ HH.h1_ [ HH.text "Home page" ]
|
|
, HH.p_ [ HH.text message ]
|
|
, whenElem (isNothing currentUser) \_ ->
|
|
HH.button
|
|
[ HP.type_ HP.ButtonButton, HE.onClick (Home_Login <<< MouseEvent.toEvent) ]
|
|
[ HH.text "Login" ]
|
|
]
|
|
where
|
|
message :: String
|
|
message = case currentUser of
|
|
Nothing -> "Welcome, guest. Log in?"
|
|
Just { username } -> "WELCOME HOME, " <> username <> "!"
|
|
|
|
handleAction :: Home_Action -> HomeM Unit
|
|
handleAction = case _ of
|
|
Home_Initialize ->
|
|
log $ "NOTE: If you're in TryPureScript's <iframe>, PushState routing will not work"
|
|
Home_Receive i ->
|
|
updateLocalState i
|
|
Home_Login event -> do
|
|
H.liftEffect $ Event.preventDefault event
|
|
loginUser "Alice" >>= case _ of
|
|
Nothing ->
|
|
pure unit
|
|
Just { username } ->
|
|
log $ username <> " has logged in!"
|
|
|
|
|
|
-- Page.Secrets
|
|
-- (visible to logged-in users)
|
|
|
|
type Secrets_State =
|
|
{ currentUser :: Maybe Profile
|
|
}
|
|
|
|
data Secrets_Action
|
|
= Secrets_Initialize
|
|
| Secrets_Receive { context :: (Maybe Profile), input :: Unit }
|
|
| Secrets_Logout Event
|
|
|
|
type Secrets_Slot = H.Slot (Const Void) Void Unit
|
|
|
|
type SecretsM = H.HalogenM Secrets_State Secrets_Action () Void AppM
|
|
type SecretsHTML = H.ComponentHTML Secrets_Action () AppM
|
|
|
|
componentSecrets :: H.Component (Const Void) Unit Void AppM
|
|
componentSecrets =
|
|
HSC.connect (HSS.selectEq _.currentUser) $
|
|
H.mkComponent { initialState, render, eval }
|
|
where
|
|
initialState :: ConnectedInput -> Secrets_State
|
|
initialState =
|
|
\{ context: currentUser } ->
|
|
{ currentUser
|
|
}
|
|
|
|
eval =
|
|
H.mkEval H.defaultEval
|
|
{ handleAction = handleAction
|
|
, initialize = Just Secrets_Initialize
|
|
, receive = Just <<< Secrets_Receive
|
|
}
|
|
|
|
render :: Secrets_State -> SecretsHTML
|
|
render { currentUser } =
|
|
maybeElem currentUser \{ username } -> do
|
|
HH.div
|
|
[ css "page" ]
|
|
[ HH.h1_ [ HH.text (username <> "'s page of secrets") ]
|
|
, HH.p_
|
|
[ HH.text "The answer is always: ", HH.code [ css "code" ] [ HH.text "traverse" ] ]
|
|
, HH.button
|
|
[ HE.onClick (Secrets_Logout <<< MouseEvent.toEvent) ]
|
|
[ HH.text "Sign out" ]
|
|
]
|
|
|
|
handleAction :: Secrets_Action -> SecretsM Unit
|
|
handleAction = case _ of
|
|
Secrets_Initialize ->
|
|
H.gets _.currentUser >>= case _ of
|
|
Nothing -> logoutUser
|
|
Just _ -> pure unit
|
|
|
|
Secrets_Receive input ->
|
|
updateLocalState input
|
|
|
|
Secrets_Logout event -> do
|
|
H.liftEffect $ Event.preventDefault event
|
|
log "Signing out" *> logoutUser
|
|
|
|
|
|
-- CSS
|
|
|
|
stylesheet :: String
|
|
stylesheet =
|
|
"""
|
|
.body {
|
|
display: flex;
|
|
flex-direction: column;
|
|
font-family: Helvetica Neue, Helvetica, Arial, sans-serif;
|
|
justify-content: space-between;
|
|
height: calc(100vh - 18px);
|
|
}
|
|
|
|
.main {
|
|
display: flex;
|
|
flex-direction: column;
|
|
justify-content: space-between;
|
|
height: calc(100vh - 100px);
|
|
}
|
|
|
|
.page {
|
|
flex: auto;
|
|
padding: 0.5rem 1.5rem;
|
|
}
|
|
|
|
.logger {
|
|
background: #282c34;
|
|
flex-basis: 275px;
|
|
color: #e06c75;
|
|
font-family: 'Consolas';
|
|
padding: 5px 20px 5px 20px;
|
|
}
|
|
|
|
.code {
|
|
color: #d63384;
|
|
}
|
|
|
|
.nav {
|
|
display: flex;
|
|
list-style: none;
|
|
padding: 0.5rem 1.0rem;
|
|
border-bottom: 1px solid black;
|
|
}
|
|
|
|
.nav-ul {
|
|
list-style-type: none;
|
|
padding-left: 0;
|
|
}
|
|
|
|
|
|
.nav-li {
|
|
display: inline-block;
|
|
padding: .5em 1em;
|
|
justify-content: space-between;
|
|
}
|
|
|
|
""" |