aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile2
-rw-r--r--README.md2
-rw-r--r--client/client.cabal12
-rw-r--r--client/src/Icon.hs58
-rw-r--r--client/src/Main.hs15
-rw-r--r--client/src/View/Payment.hs7
-rw-r--r--client/src/View/Payment/Pages.hs42
-rw-r--r--common/common.cabal12
-rw-r--r--server/server.cabal57
-rw-r--r--server/src/Design/Color.hs5
-rw-r--r--server/src/Design/View/Payment/Pages.hs6
-rw-r--r--server/src/Design/View/Payment/Table.hs2
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 16:21:43 +0000