Add mocked pages

12 files changed, 181 insertions, 39 deletions

diff --git a/Makefile b/Makefile
index 8ece441..d18fb6d 100644
--- a/Makefile
+++ b/Makefile
@@ -20,7 +20,7 @@ clean-client:
 	@rm -rf dist-client
 
 build-client:
-	@nix-shell -A shells.ghcjs --run "build-client-inside"
+	@nix-shell -A shells.ghcjs --run "make build-client-inside"
 
 build-client-inside:
 	@cabal --project-file=cabal-client.project --builddir=dist-client new-build all
diff --git a/README.md b/README.md
index 800a984..e9762ea 100644
--- a/README.md
+++ b/README.md
@@ -58,9 +58,9 @@ See [application.conf](application.conf).
 TODO
 ----
 
-- use jsaddle-dom in client/Main.hs
 - move persistence methods to a module
 - use another route to check the token and redirect to /
+- migration diff (use flyway?)
 
 - Add payment balance in weekly report
 - search by payment category and payment date
diff --git a/client/client.cabal b/client/client.cabal
index 7807d37..9d3e873 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -16,9 +16,19 @@ executable client
                      , bytestring
                      , common
                      , containers
-                     , ghcjs-dom-jsffi
+                     , jsaddle-dom
                      , reflex-dom
                      , text
                      , time
   hs-source-dirs:      src
   default-language:    Haskell2010
+  other-modules:       Component.Button
+                     , Component.Input
+                     , Icon
+                     , Main
+                     , View.App
+                     , View.Header
+                     , View.Payment
+                     , View.Payment.Pages
+                     , View.Payment.Table
+                     , View.SignIn
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index 7223def..6b2749a 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -2,11 +2,15 @@
 {-# LANGUAGE OverloadedStrings         #-}
 
 module Icon
-  ( loading
-  , signOut
-  , clone
-  , edit
+  ( clone
   , delete
+  , edit
+  , loading
+  , doubleLeft
+  , doubleLeftBar
+  , doubleRight
+  , doubleRightBar
+  , signOut
   ) where
 
 import Data.Map (Map)
@@ -15,30 +19,50 @@ import Data.Text (Text)
 import Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-loading :: forall t m. MonadWidget t m => m ()
-loading =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
-    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
-
-signOut :: forall t m. MonadWidget t m => m ()
-signOut =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
-
 clone :: forall t m. MonadWidget t m => m ()
 clone =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
     svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
 
+delete :: forall t m. MonadWidget t m => m ()
+delete =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+
+doubleLeft :: forall t m. MonadWidget t m => m ()
+doubleLeft =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank
+
+doubleLeftBar :: forall t m. MonadWidget t m => m ()
+doubleLeftBar =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank
+
+doubleRight :: forall t m. MonadWidget t m => m ()
+doubleRight =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
+
+doubleRightBar :: forall t m. MonadWidget t m => m ()
+doubleRightBar =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
+
 edit :: forall t m. MonadWidget t m => m ()
 edit =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
     svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
 
-delete :: forall t m. MonadWidget t m => m ()
-delete =
+loading :: forall t m. MonadWidget t m => m ()
+loading =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
+    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
+
+signOut :: forall t m. MonadWidget t m => m ()
+signOut =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
 
 svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
 svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/Main.hs b/client/src/Main.hs
index 1f167d4..14f0fee 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -4,11 +4,13 @@ module Main
 
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as LB
-import Data.JSString.Text (textFromJSString)
+import qualified Data.JSString.Text as Dom
 import qualified Data.Text.Encoding as T
-import qualified GHCJS.DOM as Dom
-import qualified GHCJS.DOM.NonElementParentNode as Dom
-import GHCJS.DOM.Types (JSM, Element, JSString)
+import qualified JSDOM as Dom
+import qualified JSDOM.Generated.HTMLElement as Dom
+import qualified JSDOM.Generated.NonElementParentNode as Dom
+import JSDOM.Types (JSM, HTMLElement(..))
+import qualified JSDOM.Types as Dom
 import Prelude hiding (init, error)
 
 import Common.Model (InitResult(InitEmpty))
@@ -28,13 +30,10 @@ readInit = do
   initNode <- Dom.getElementById document "init"
   case initNode of
     Just node -> do
-      text <- textFromJSString <$> js_getInnerText node
+      text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
       return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
         Just init -> init
         Nothing -> initParseError
     _ ->
       return initParseError
   where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
-
-foreign import javascript unsafe "$1[\"innerText\"]"
-  js_getInnerText :: Element -> IO JSString
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index e80790b..d1430c9 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -11,8 +11,10 @@ module View.Payment
 import Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-import Common.Model (Init)
+import Common.Model (Init(..))
 
+import View.Payment.Pages (PagesIn(..))
+import qualified View.Payment.Pages as Pages
 import View.Payment.Table (TableIn(..))
 import qualified View.Payment.Table as Table
 
@@ -30,4 +32,7 @@ widget paymentIn = do
     _ <- Table.widget $ TableIn
       { _tableIn_init = _paymentIn_init paymentIn
       }
+    _ <- Pages.widget $ PagesIn
+      { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn
+      }
     return $ PaymentOut {}
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
new file mode 100644
index 0000000..f9a2b4e
--- /dev/null
+++ b/client/src/View/Payment/Pages.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment.Pages
+  ( widget
+  , PagesIn(..)
+  , PagesOut(..)
+  ) where
+
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Payment(..))
+
+import qualified Icon
+
+data PagesIn = PagesIn
+  { _pagesIn_payments :: [Payment]
+  }
+
+data PagesOut = PagesOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut
+widget _ = do
+  R.divClass "pages" $ do
+    page Icon.doubleLeftBar
+    page Icon.doubleLeft
+    page (R.text . T.pack . show $ (1 :: Integer))
+    page (R.text . T.pack . show $ (2 :: Integer))
+    page (R.text . T.pack . show $ (3 :: Integer))
+    page (R.text . T.pack . show $ (4 :: Integer))
+    page (R.text . T.pack . show $ (5 :: Integer))
+    page Icon.doubleRight
+    page Icon.doubleRightBar
+  return $ PagesOut {}
+
+page :: forall t m. MonadWidget t m => m () -> m ()
+page content = R.elClass "button" "page" $ content
diff --git a/common/common.cabal b/common/common.cabal
index e072acf..8b60743 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -10,6 +10,12 @@ cabal-version:       >=1.10
 
 library
   ghc-options:         -Wall -Werror
+  build-depends:       aeson
+                     , base >=4.9 && <4.11
+                     , text
+                     , time
+  hs-source-dirs:      src
+  default-language:    Haskell2010
   exposed-modules:     Common.Message
                      , Common.Message.Key
                      , Common.Model
@@ -33,9 +39,3 @@ library
                      , Common.Model.SignIn
                      , Common.Model.Init
                      , Common.Model.User
-  build-depends:       aeson
-                     , base >=4.9 && <4.11
-                     , text
-                     , time
-  hs-source-dirs:      src
-  default-language:    Haskell2010
diff --git a/server/server.cabal b/server/server.cabal
index 8bbe5f2..41b2fd6 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -32,8 +32,8 @@ executable server
                      , mtl
                      , parsec
                      , process
-                     , resourcet
                      , random
+                     , resourcet
                      , scotty
                      , sqlite-simple
                      , text
@@ -46,3 +46,58 @@ executable server
                      , wai-middleware-static
   hs-source-dirs:      src
   default-language:    Haskell2010
+  other-modules:       Conf
+                     , Controller.Category
+                     , Controller.Income
+                     , Controller.Index
+                     , Controller.Payment
+                     , Controller.SignIn
+                     , Cookie
+                     , Design.Color
+                     , Design.Constants
+                     , Design.Dialog
+                     , Design.Errors
+                     , Design.Form
+                     , Design.Global
+                     , Design.Helper
+                     , Design.Media
+                     , Design.Tooltip
+                     , Design.View.Header
+                     , Design.View.Payment
+                     , Design.View.Payment.Header
+                     , Design.View.Payment.Pages
+                     , Design.View.Payment.Table
+                     , Design.View.SignIn
+                     , Design.View.Stat
+                     , Design.View.Table
+                     , Design.Views
+                     , Job.Daemon
+                     , Job.Frequency
+                     , Job.Kind
+                     , Job.Model
+                     , Job.MonthlyPayment
+                     , Job.WeeklyReport
+                     , Json
+                     , LoginSession
+                     , Main
+                     , MimeMail
+                     , Model.Category
+                     , Model.Frequency
+                     , Model.Income
+                     , Model.Init
+                     , Model.Mail
+                     , Model.Payer
+                     , Model.Payment
+                     , Model.PaymentCategory
+                     , Model.Query
+                     , Model.SignIn
+                     , Model.UUID
+                     , Model.User
+                     , Resource
+                     , Secure
+                     , SendMail
+                     , Utils.Time
+                     , Validation
+                     , View.Mail.SignIn
+                     , View.Mail.WeeklyReport
+                     , View.Page
diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs
index 06c468e..9a5797f 100644
--- a/server/src/Design/Color.hs
+++ b/server/src/Design/Color.hs
@@ -1,6 +1,8 @@
 module Design.Color where
 
+import Clay
 import qualified Clay.Color as C
+import Data.Text (Text)
 
 -- http://chir.ag/projects/name-that-color/#969696
 
@@ -33,3 +35,6 @@ silver = C.rgb 200 200 200
 
 dustyGray :: C.Color
 dustyGray = C.rgb 150 150 150
+
+toString :: C.Color -> Text
+toString = plain . unValue . value
diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs
index ade81a8..5fc13f0 100644
--- a/server/src/Design/View/Payment/Pages.hs
+++ b/server/src/Design/View/Payment/Pages.hs
@@ -13,8 +13,8 @@ import qualified Design.Media as Media
 
 design :: Css
 design = do
-  textAlign (alignSide sideCenter)
-  Helper.clearFix
+  display flex
+  justifyContent center
 
   Media.desktop $ do
     padding (px 40) (px 30) (px 30) (px 30)
@@ -26,6 +26,8 @@ design = do
     padding (px 20) (px 0) (px 20) (px 0)
     lineHeight (px 40)
 
+  svg ? "path" ? ("fill" -: Color.toString Color.dustyGray)
+
   ".page" ? do
     display inlineBlock
     fontWeight bold
diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs
index a866b40..f8326e4 100644
--- a/server/src/Design/View/Payment/Table.hs
+++ b/server/src/Design/View/Payment/Table.hs
@@ -38,5 +38,5 @@ design = do
         marginBottom (em 0.5)
 
     ".button" & svg ? do
-      "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose))
+      "path" ? ("fill" -: Color.toString Color.chestnutRose)
       width (px 18)