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