From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- ISSUES.md | 9 +- Makefile | 4 +- README.md | 4 +- 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 +- common/src/Common/Message/Key.hs | 3 + common/src/Common/Message/Translation.hs | 10 ++ server/server.cabal | 1 + server/src/Controller/Index.hs | 2 +- server/src/Design/View/Header.hs | 7 +- server/src/Design/View/NotFound.hs | 21 +++ server/src/Design/Views.hs | 21 +-- server/src/Main.hs | 36 +++-- 24 files changed, 550 insertions(+), 85 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 create mode 100644 server/src/Design/View/NotFound.hs diff --git a/ISSUES.md b/ISSUES.md index 1286596..b7d31c3 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,7 +1,3 @@ -# MVP - -- Implement routing - ## Income view - Show the income table @@ -16,6 +12,11 @@ - Edit a category - Remove a category +## Phone + +- Slow, consider native ? +- Fix sign-in responsiveness + # Additional features - Remove unused payment category after payment edit on frontend diff --git a/Makefile b/Makefile index 31d9a62..5c615b3 100644 --- a/Makefile +++ b/Makefile @@ -29,7 +29,7 @@ cp-client: @cp dist-client/build/x86_64-linux/ghcjs-*/client-*/*/client/build/client/client.jsexe/all.js public/javascript/main.js watch-client: - @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" + @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(tput reset && make build-client-inside && make cp-client) || true'" # Server # ------ @@ -48,4 +48,4 @@ run-server: @./dist-server/build/x86_64-linux/ghc-*/server-0.0.1/*/server/build/server/server watch-server: - @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" + @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(tput reset && make build-server-inside && make run-server) || :'" diff --git a/README.md b/README.md index 6e1c675..7f8d8f3 100644 --- a/README.md +++ b/README.md @@ -53,8 +53,8 @@ See [application.conf](application.conf). ## Documentation -- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html) -- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html) +- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.4/docs/doc-index-All.html) +- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-core-0.5/docs/doc-index-All.html) ## Issues 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) diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index e460d3e..c2fde58 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -150,3 +150,6 @@ data Key = | WeeklyReport_PaymentDeleted Int | WeeklyReport_PaymentEdited Int | WeeklyReport_Title + + | NotFound_Message + | NotFound_LinkMessage diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 6b9e7be..3173561 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -693,3 +693,13 @@ m l WeeklyReport_Title = case l of English -> "Weekly report" French -> "Rapport hebdomadaire" + +m l NotFound_Message = + case l of + English -> "There is nothing here!" + French -> "Vous vous êtes perdu." + +m l NotFound_LinkMessage = + case l of + English -> "Go back to the home page." + French -> "Retour à l’accueil." diff --git a/server/server.cabal b/server/server.cabal index ea7ebed..75af442 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -73,6 +73,7 @@ Executable server Design.Modal Design.Tooltip Design.View.Header + Design.View.NotFound Design.View.Payment Design.View.Payment.Add Design.View.Payment.Delete diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index fbda527..5ebe921 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -57,7 +57,7 @@ askSignIn conf form = let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, - "/signIn/", + "/api/signIn/", token ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 2422686..59e0e51 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -40,8 +40,11 @@ design = do ".current" & backgroundColor (Color.chestnutRose -. 20) Media.mobile $ fontSize (px 13) - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + (".item" # hover) <> (".item" # focus) ? + backgroundColor (Color.chestnutRose +. 10) + + (".item.current" # hover) <> (".item.current" # focus) ? + backgroundColor (Color.chestnutRose -. 10) ".nameSignOut" ? do display flex diff --git a/server/src/Design/View/NotFound.hs b/server/src/Design/View/NotFound.hs new file mode 100644 index 0000000..150c6fc --- /dev/null +++ b/server/src/Design/View/NotFound.hs @@ -0,0 +1,21 @@ +module Design.View.NotFound + ( design + ) where + +import Clay +import Prelude hiding (rem) + +import qualified Design.Color as Color + +design :: Css +design = do + + marginLeft (rem 3) + + ".link" ? do + display block + marginTop (rem 1) + color Color.chestnutRose + textDecoration underline + hover & + color (Color.chestnutRose +. 15) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index b9e3cf8..bf39cff 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,16 +4,16 @@ module Design.Views import Clay -import qualified Design.View.Header as Header -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table design :: Css design = do @@ -21,6 +21,7 @@ design = do ".payment" ? Payment.design ".signIn" ? SignIn.design ".stat" ? Stat.design + ".notfound" ? NotFound.design Table.design ".withMargin" ? do diff --git a/server/src/Main.hs b/server/src/Main.hs index 0ccf5e2..e3dad9e 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -15,48 +15,52 @@ main = do conf <- Conf.get "application.conf" _ <- runDaemons conf S.scotty (Conf.port conf) $ do - S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } - S.middleware . staticPolicy $ noDots >-> addBase "public" - S.get "/" $ do - Index.get conf + S.middleware $ + W.gzip $ W.def { W.gzipFiles = GzipCompress } + + S.middleware . staticPolicy $ + noDots >-> addBase "public" - S.post "/askSignIn" $ do + S.post "/api/askSignIn" $ S.jsonData >>= Index.askSignIn conf - S.get "/signIn/:signInToken" $ do + S.get "/api/signIn/:signInToken" $ do signInToken <- S.param "signInToken" Index.trySignIn conf signInToken - S.post "/signOut" $ + S.post "/api/signOut" $ Index.signOut conf - S.post "/payment" $ + S.post "/api/payment" $ S.jsonData >>= Payment.create - S.put "/payment" $ + S.put "/api/payment" $ S.jsonData >>= Payment.edit - S.delete "/payment/:id" $ do + S.delete "/api/payment/:id" $ do paymentId <- S.param "id" Payment.delete paymentId - S.post "/income" $ + S.post "/api/income" $ S.jsonData >>= Income.create - S.put "/income" $ + S.put "/api/income" $ S.jsonData >>= Income.edit - S.delete "/income/:id" $ do + S.delete "/api/income/:id" $ do incomeId <- S.param "id" Income.delete incomeId - S.post "/category" $ + S.post "/api/category" $ S.jsonData >>= Category.create - S.put "/category" $ + S.put "/api/category" $ S.jsonData >>= Category.edit - S.delete "/category/:id" $ do + S.delete "/api/category/:id" $ do categoryId <- S.param "id" Category.delete categoryId + + S.notFound $ + Index.get conf -- cgit v1.2.3