From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- client/client.cabal | 12 ++ client/src/Component.hs | 1 + client/src/Component/Link.hs | 33 +++++ client/src/Model/Route.hs | 9 ++ client/src/Util/Css.hs | 9 ++ client/src/Util/Router.hs | 266 ++++++++++++++++++++++++++++++++++++++ client/src/View/App.hs | 87 +++++++++---- client/src/View/Header.hs | 65 +++++++--- client/src/View/NotFound.hs | 20 +++ client/src/View/Payment.hs | 9 +- client/src/View/Payment/Delete.hs | 2 +- client/src/View/Payment/Form.hs | 2 +- client/src/View/SignIn.hs | 2 +- 13 files changed, 469 insertions(+), 48 deletions(-) create mode 100644 client/src/Component/Link.hs create mode 100644 client/src/Model/Route.hs create mode 100644 client/src/Util/Css.hs create mode 100644 client/src/Util/Router.hs create mode 100644 client/src/View/NotFound.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 5fc20ae..55ba5e1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -35,22 +35,34 @@ Executable client , time , validation + -- Router + , ghcjs-base + , ghcjs-prim + , ghcjs-dom + , jsaddle + , lens + , uri-bytestring + other-modules: Component Component.Button Component.Form Component.Input + Component.Link Component.Modal Component.Select Icon Util.Ajax + Util.Css Util.Either Util.List Util.Reflex + Util.Router Util.Validation Util.WaitFor View.App View.Header + View.NotFound View.Payment View.Payment.Add View.Payment.Clone diff --git a/client/src/Component.hs b/client/src/Component.hs index 7b87a75..7e0b151 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -3,5 +3,6 @@ module Component (module X) where import Component.Button as X import Component.Form as X import Component.Input as X +import Component.Link as X import Component.Modal as X import Component.Select as X diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs new file mode 100644 index 0000000..7e8558b --- /dev/null +++ b/client/src/Component/Link.hs @@ -0,0 +1,33 @@ +module Component.Link + ( link + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () +link href inputAttrs content = + R.elDynAttr "a" attrs (R.text content) + where + + onclickHandler = + T.intercalate ";" + [ "history.pushState(0, '', event.target.href)" + , "dispatchEvent(new PopStateEvent('popstate', {cancelable: true, bubbles: true, view: window}))" + , "return false" + ] + + attrs = + R.ffor inputAttrs (\as -> + (M.union + (M.fromList + [ ("onclick", onclickHandler) + , ("href", href) + ] + ) + as) + ) diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs new file mode 100644 index 0000000..420fe05 --- /dev/null +++ b/client/src/Model/Route.hs @@ -0,0 +1,9 @@ +module Model.Route + ( Route(..) + ) where + +data Route + = RootRoute + | IncomeRoute + | NotFoundRoute + deriving (Eq, Show) diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs new file mode 100644 index 0000000..804b10f --- /dev/null +++ b/client/src/Util/Css.hs @@ -0,0 +1,9 @@ +module Util.Css + ( classes + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +classes :: [(Text, Bool)] -> Text +classes = T.unwords . map fst . filter snd diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs new file mode 100644 index 0000000..e9d0a1a --- /dev/null +++ b/client/src/Util/Router.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Util.Router ( + -- == High-level routers + route + , route' + , partialPathRoute + + -- = Low-level URL bar access + , getLoc + , getURI + , getUrlText + , uriOrigin + , URI + + -- = History movement + , goForward + , goBack + ) where + +------------------------------------------------------------------------------ +import Control.Lens ((&), (.~), (^.)) +import Control.Monad.Fix (MonadFix) +import qualified Data.ByteString.Char8 as BS +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHCJS.DOM (currentDocumentUnchecked, + currentWindowUnchecked) +import GHCJS.DOM.Document (createEvent) +import GHCJS.DOM.Event (initEvent) +import GHCJS.DOM.EventM (on) +import GHCJS.DOM.EventTarget (dispatchEvent_) +import GHCJS.DOM.History (History, back, forward, + pushState) +import GHCJS.DOM.Location (getHref) +import GHCJS.DOM.PopStateEvent +import GHCJS.DOM.Types (Location (..), + PopStateEvent (..)) +import GHCJS.DOM.Types (MonadJSM, uncheckedCastTo) +import qualified GHCJS.DOM.Types as DOM +import GHCJS.DOM.Window (getHistory, getLocation) +import GHCJS.DOM.WindowEventHandlers (popState) +import GHCJS.Foreign (isFunction) +import GHCJS.Marshal.Pure (pFromJSVal) +import Language.Javascript.JSaddle (JSM, Object (..), ghcjsPure, + liftJSM) +import qualified Language.Javascript.JSaddle as JS +import Reflex.Dom.Core hiding (EventName, Window) +import qualified URI.ByteString as U +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------- +-- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic +-- routing of a widget +-- These sources of URL-bar change will be reflected in the output URI +-- - Input events to 'route' +-- - Browser Forward/Back button clicks +-- - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls +-- - Any URL changes followed by a popState event +-- But external calls to pushState that don't manually fire a popState +-- won't be detected +route + :: forall t m. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m)) + => Event t T.Text + -> m (Dynamic t (U.URIRef U.Absolute)) +route pushTo = do + loc0 <- getURI + + _ <- performEvent $ ffor pushTo $ \t -> do + let newState = Just t + withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text) + liftJSM dispatchEvent' + + locUpdates <- getPopState + holdDyn loc0 locUpdates + +route' + :: forall t m a b. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => (URI -> a -> URI) + -> (URI -> b) + -> Event t a + -> m (Dynamic t b) +route' encode decode routeUpdate = do + rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates) + let urlUpdates = attachWith encode (current rUri) routeUpdate + return $ decode <$> rUri + + +------------------------------------------------------------------------------- +-- | Route a single page app according to the part of the path after +-- pathBase +partialPathRoute + :: forall t m. + ( MonadHold t m + , PostBuild t m + , DomBuilder t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => T.Text -- ^ The path segments not related to SPA routing + -- (leading '/' will be added automaticaly) + -> Event t T.Text -- ^ Updates to the path segments used for routing + -- These values will be appended to the base path + -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing +partialPathRoute pathBase pathUpdates = do + route' (flip updateUrl) parseParts pathUpdates + where + + rootPathBase :: T.Text + rootPathBase = + if T.null pathBase then + "" + else + "/" <> cleanT pathBase + + toPath :: T.Text -> BS.ByteString + toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath + + updateUrl :: T.Text -> URI -> URI + updateUrl updateParts u = u & U.pathL .~ toPath updateParts + + parseParts :: URI -> [T.Text] + parseParts u = + maybe (error $ pfxErr u pathBase) + (T.splitOn "/" . T.decodeUtf8 . cleanB) . + BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $ + cleanB (u ^. U.pathL) + + cleanT = T.dropWhile (=='/') + cleanB = BS.dropWhile (== '/') + + +------------------------------------------------------------------------------- +uriOrigin :: U.URIRef U.Absolute -> T.Text +uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r' + where + r' = r { U.uriPath = mempty + , U.uriQuery = mempty + , U.uriFragment = mempty + } + + +------------------------------------------------------------------------------- +getPopState + :: forall t m. + ( MonadHold t m + , TriggerEvent t m + , MonadJSM m) => m (Event t URI) +getPopState = do + window <- currentWindowUnchecked + wrapDomEventMaybe window (`on` popState) $ do + loc <- getLocation window + locStr <- getHref loc + return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr) + + +------------------------------------------------------------------------------- +goForward :: (HasJSContext m, MonadJSM m) => m () +goForward = withHistory forward + + +------------------------------------------------------------------------------- +goBack :: (HasJSContext m, MonadJSM m) => m () +goBack = withHistory back + + +------------------------------------------------------------------------------- +withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a +withHistory act = do + w <- currentWindowUnchecked + h <- getHistory w + act h + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window +getLoc :: (HasJSContext m, MonadJSM m) => m Location +getLoc = do + win <- currentWindowUnchecked + loc <- getLocation win + return loc + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the URL text of a window +getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text +getUrlText = getLoc >>= getHref + + +------------------------------------------------------------------------------- +type URI = U.URIRef U.Absolute + + +------------------------------------------------------------------------------- +getURI :: (HasJSContext m, MonadJSM m) => m URI +getURI = do + l <- getUrlText + return $ either (error "No parse of window location") id . + U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l + + +dispatchEvent' :: JSM () +dispatchEvent' = do + window <- currentWindowUnchecked + obj@(Object o) <- JS.create + JS.objSetPropertyByName obj ("cancelable" :: Text) True + JS.objSetPropertyByName obj ("bubbles" :: Text) True + JS.objSetPropertyByName obj ("view" :: Text) window + event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case + True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o + False -> do + doc <- currentDocumentUnchecked + event <- createEvent doc ("PopStateEvent" :: Text) + initEvent event ("popstate" :: Text) True True + JS.objSetPropertyByName obj ("view" :: Text) window + return $ uncheckedCastTo PopStateEvent event + + dispatchEvent_ window event + + +------------------------------------------------------------------------------- +hush :: Either e a -> Maybe a +hush (Right a) = Just a +hush _ = Nothing + + +------------------------------------------------------------------------------- +pfxErr :: URI -> T.Text -> String +pfxErr pn pathBase = + T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn) + <> ") without expected prefix (" <> pathBase <> ")" diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 6435297..d853c7e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,41 +2,84 @@ module View.App ( widget ) where -import Prelude hiding (error, init) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (InitResult (..)) -import qualified Common.Msg as Msg +import Common.Model (Init, InitResult (..)) +import qualified Common.Msg as Msg -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import Model.Route (Route (..)) +import qualified Util.Router as Router +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import qualified View.NotFound as NotFound +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = R.mainWidget $ R.divClass "app" $ do + route <- getRoute + headerOut <- Header.view $ HeaderIn { _headerIn_initResult = initResult + , _headerIn_isInitSuccess = + case initResult of + InitSuccess _ -> True + _ -> False + , _headerIn_route = route } - let signOut = Header._headerOut_signOut headerOut + let signOut = + Header._headerOut_signOut headerOut + + mainContent = + case initResult of + InitSuccess init -> + signedWidget init route + + InitEmpty -> + SignIn.view SignIn.EmptyMessage - initialContent = case initResult of - InitSuccess initSuccess -> do - _ <- Payment.widget $ PaymentIn - { _paymentIn_init = initSuccess - } - return () - InitEmpty -> - SignIn.view SignIn.EmptyMessage - InitError error -> - SignIn.view (SignIn.ErrorMessage error) + InitError error -> + SignIn.view (SignIn.ErrorMessage error) - signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) + signOutContent = + SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) - _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + _ <- R.widgetHold (mainContent) (signOutContent <$ signOut) R.blank + +signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget init route = do + R.dyn . R.ffor route $ \case + RootRoute -> + Payment.widget $ PaymentIn + { _paymentIn_init = init + } + + IncomeRoute -> + R.el "div" $ R.text "Incomes" + + NotFoundRoute -> + NotFound.view + + return () + +getRoute :: MonadWidget t m => m (Dynamic t Route) +getRoute = do + r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never + return . R.ffor r $ \case + [""] -> + RootRoute + + ["income"] -> + IncomeRoute + + _ -> + NotFoundRoute diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 8f1fb78..9a4de89 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -4,40 +4,73 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Component as Component -import Component.Button (ButtonIn (..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import Component (ButtonIn (..)) +import qualified Component as Component import qualified Icon +import Model.Route (Route (..)) +import qualified Util.Css as CssUtil +import qualified Util.Reflex as ReflexUtil -data HeaderIn = HeaderIn - { _headerIn_initResult :: InitResult +data HeaderIn t = HeaderIn + { _headerIn_initResult :: InitResult + , _headerIn_isInitSuccess :: Bool + , _headerIn_route :: Dynamic t Route } data HeaderOut t = HeaderOut { _headerOut_signOut :: Event t () } -view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t) view headerIn = R.el "header" $ do R.divClass "title" $ R.text $ Msg.get Msg.App_Title - signOut <- nameSignOut $ _headerIn_initResult headerIn + signOut <- R.el "div" $ do + rec + showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut) + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn) + signOut <- nameSignOut $ _headerIn_initResult headerIn + return signOut return $ HeaderOut { _headerOut_signOut = signOut } +links :: forall t m. MonadWidget t m => Dynamic t Route -> m () +links route = do + Component.link + "/" + (R.ffor route (attrs RootRoute)) + (Msg.get Msg.Payment_Title) + + Component.link + "/income" + (R.ffor route (attrs IncomeRoute)) + (Msg.get Msg.Income_Title) + + where + attrs linkRoute currentRoute = + M.singleton "class" $ + CssUtil.classes + [ ("item", True) + , ("current", linkRoute == currentRoute) + ] + nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) nameSignOut initResult = case initResult of (InitSuccess init) -> do @@ -76,5 +109,5 @@ signOutButton = do where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) askSignOut signOut = fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut getResult = (== 200) . R._xhrResponse_status diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs new file mode 100644 index 0000000..1d4e477 --- /dev/null +++ b/client/src/View/NotFound.hs @@ -0,0 +1,20 @@ +module View.NotFound + ( view + ) where + +import qualified Data.Map as M +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component as Component + +view :: forall t m. MonadWidget t m => m () +view = + R.divClass "notfound" $ do + R.text (Msg.get Msg.NotFound_Message) + + Component.link + "/" + (R.constDyn $ M.singleton "class" "link") + (Msg.get Msg.NotFound_LinkMessage) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f2a5071..1072a5e 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,7 +1,6 @@ module View.Payment ( widget , PaymentIn(..) - , PaymentOut(..) ) where import Data.Text (Text) @@ -26,11 +25,7 @@ data PaymentIn = PaymentIn { _paymentIn_init :: Init } -data PaymentOut = PaymentOut - { - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget :: forall t m. MonadWidget t m => PaymentIn -> m () widget paymentIn = do R.elClass "main" "payment" $ do rec @@ -86,7 +81,7 @@ widget paymentIn = do ] } - pure $ PaymentOut {} + pure () debounceSearchName :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index e7e319e..521c1a7 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -44,7 +44,7 @@ view input _ = let url = R.ffor (_input_payment input) (\id -> - T.concat ["/payment/", T.pack . show $ _payment_id id] + T.concat ["/api/payment/", T.pack . show $ _payment_id id] ) (result, waiting) <- WaitFor.waitFor diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 187b64b..7819836 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -143,7 +143,7 @@ view input = do }) (addPayment, waiting) <- WaitFor.waitFor - (ajax "/payment") + (ajax "/api/payment") (ValidationUtil.fireValidation payment confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index f8b985f..8c248bd 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/askSignIn") + (Ajax.postJson "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3