aboutsummaryrefslogtreecommitdiff
path: root/client/src
diff options
context:
space:
mode:
Diffstat (limited to 'client/src')
-rw-r--r--client/src/Component.hs1
-rw-r--r--client/src/Component/Link.hs33
-rw-r--r--client/src/Model/Route.hs9
-rw-r--r--client/src/Util/Css.hs9
-rw-r--r--client/src/Util/Router.hs266
-rw-r--r--client/src/View/App.hs87
-rw-r--r--client/src/View/Header.hs65
-rw-r--r--client/src/View/NotFound.hs20
-rw-r--r--client/src/View/Payment.hs9
-rw-r--r--client/src/View/Payment/Delete.hs2
-rw-r--r--client/src/View/Payment/Form.hs2
-rw-r--r--client/src/View/SignIn.hs2
12 files changed, 457 insertions, 48 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 00:13:30 +0000