From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 00:20:25 +0100
Subject: Show payment count and partition

- Also fixes exceedingPayer in back by using only punctual payments
---
 client/src/Util/List.hs | 13 +++++++++++++
 1 file changed, 13 insertions(+)
 create mode 100644 client/src/Util/List.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
new file mode 100644
index 0000000..4e22ba8
--- /dev/null
+++ b/client/src/Util/List.hs
@@ -0,0 +1,13 @@
+module Util.List
+  ( groupBy
+  ) where
+
+import           Control.Arrow ((&&&))
+import           Data.Function (on)
+import qualified Data.List     as L
+
+groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
+groupBy f =
+  map (f . head &&& id)
+    . L.groupBy ((==) `on` f)
+    . L.sortBy (compare `on` f)
-- 
cgit v1.2.3


From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 3 Jan 2018 17:31:20 +0100
Subject: Modify weelky report and payment search interface

- Add payment balance in weekly report
- Show a message and hide pages when the search results in no results
- Go to page 1 when the search is updated / erased
---
 client/src/Util/Dom.hs | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)
 create mode 100644 client/src/Util/Dom.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
new file mode 100644
index 0000000..f3e9c88
--- /dev/null
+++ b/client/src/Util/Dom.hs
@@ -0,0 +1,19 @@
+module Util.Dom
+  ( divVisibleIf
+  , divClassVisibleIf
+  ) where
+
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
+divVisibleIf cond content = divClassVisibleIf cond "" content
+
+divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
+divClassVisibleIf cond className content =
+  R.elDynAttr
+    "div"
+    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
+    content
-- 
cgit v1.2.3


From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Jan 2018 12:13:09 +0100
Subject: WIP

---
 client/src/Util/Ajax.hs    | 20 ++++++++++++++++++++
 client/src/Util/WaitFor.hs | 18 ++++++++++++++++++
 2 files changed, 38 insertions(+)
 create mode 100644 client/src/Util/Ajax.hs
 create mode 100644 client/src/Util/WaitFor.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
new file mode 100644
index 0000000..1e8e4c7
--- /dev/null
+++ b/client/src/Util/Ajax.hs
@@ -0,0 +1,20 @@
+module Util.Ajax
+  ( post
+  ) where
+
+import           Data.Aeson (ToJSON)
+import           Data.Text  (Text)
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
+post url input =
+  fmap getResult <$> R.performRequestAsync xhrRequest
+  where xhrRequest = R.postJson url <$> input
+        getResult response =
+          case R._xhrResponse_responseText response of
+            Just responseText ->
+              if R._xhrResponse_status response == 200
+                then Right responseText
+                else Left responseText
+            _ -> Left "NoKey"
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
new file mode 100644
index 0000000..0175c95
--- /dev/null
+++ b/client/src/Util/WaitFor.hs
@@ -0,0 +1,18 @@
+module Util.WaitFor
+  ( waitFor
+  ) where
+
+import           Data.Time  (NominalDiffTime)
+import           Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+waitFor
+  :: forall t m a b. MonadWidget t m
+  => (Event t a -> m (Event t b))
+  -> Event t ()
+  -> Dynamic t a
+  -> m (Event t b, Event t Bool)
+waitFor op start input = do
+  result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime)
+  let waiting = R.leftmost [ const True <$> start , const False <$> result ]
+  return (result, waiting)
-- 
cgit v1.2.3


From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Oct 2018 17:57:58 +0100
Subject: Delete payment

---
 client/src/Util/Ajax.hs | 67 +++++++++++++++++++++++++++++++++++++------------
 client/src/Util/Dom.hs  | 36 ++++++++++++++++++++++----
 2 files changed, 82 insertions(+), 21 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 1e8e4c7..14675df 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,55 @@
 module Util.Ajax
-  ( post
+  ( postJson
+  , delete
   ) where
 
-import           Data.Aeson (ToJSON)
-import           Data.Text  (Text)
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
+import           Data.Aeson    (ToJSON)
+import           Data.Default  (def)
+import qualified Data.Map.Lazy as LM
+import           Data.Text     (Text)
+import           Reflex.Dom    (Dynamic, Event, IsXhrPayload, MonadWidget,
+                                XhrRequest, XhrRequestConfig (..), XhrResponse,
+                                XhrResponseHeaders (..))
+import qualified Reflex.Dom    as R
 
-post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
-post url input =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = R.postJson url <$> input
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just responseText ->
-              if R._xhrResponse_status response == 200
-                then Right responseText
-                else Left responseText
-            _ -> Left "NoKey"
+postJson
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text Text))
+postJson url input =
+  fmap getResult <$>
+    R.performRequestAsync (R.postJson url <$> input)
+
+delete
+  :: forall t m. MonadWidget t m
+  => Dynamic t Text
+  -> Event t ()
+  -> m (Event t (Either Text Text))
+delete url fire =
+  fmap getResult <$>
+    R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+
+getResult :: XhrResponse -> Either Text Text
+getResult response =
+  case R._xhrResponse_responseText response of
+    Just responseText ->
+      if R._xhrResponse_status response == 200
+        then Right responseText
+        else Left responseText
+    _ -> Left "NoKey"
+
+request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
+request method url sendData =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = sendData
+      }
+  in
+    R.xhrRequest method url config
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
index f3e9c88..55b8521 100644
--- a/client/src/Util/Dom.hs
+++ b/client/src/Util/Dom.hs
@@ -1,12 +1,31 @@
 module Util.Dom
-  ( divVisibleIf
+  ( divIfDyn
+  , divIfEvent
+  , divVisibleIf
   , divClassVisibleIf
+  , getBody
   ) where
 
-import qualified Data.Map   as M
-import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Map                 as M
+import           Data.Text                (Text)
+import qualified GHCJS.DOM                as Dom
+import qualified GHCJS.DOM.Document       as Document
+import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
+import           GHCJS.DOM.Types          (Element)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
+divIfDyn cond = divIfEvent (R.updated cond)
+
+divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+divIfEvent cond empty content =
+  R.widgetHold empty (flip fmap cond (\show ->
+    if show
+      then
+        content
+      else
+        empty))
 
 divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
 divVisibleIf cond content = divClassVisibleIf cond "" content
@@ -17,3 +36,10 @@ divClassVisibleIf cond className content =
     "div"
     (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
     content
+
+getBody :: forall t m. MonadWidget t m => m Element
+getBody = do
+  document <- Dom.currentDocumentUnchecked
+  nodelist <- Document.getElementsByTagName document ("body" :: String)
+  Just body <- nodelist `HTMLCollection.item` 0
+  return body
-- 
cgit v1.2.3


From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 18:04:58 +0100
Subject: Update table when adding or removing a payment

---
 client/src/Util/Ajax.hs   | 40 +++++++++++++++++++++++++---------------
 client/src/Util/Either.hs |  7 +++++++
 2 files changed, 32 insertions(+), 15 deletions(-)
 create mode 100644 client/src/Util/Either.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 14675df..0d76638 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -3,32 +3,42 @@ module Util.Ajax
   , delete
   ) where
 
-import           Data.Aeson    (ToJSON)
-import           Data.Default  (def)
-import qualified Data.Map.Lazy as LM
-import           Data.Text     (Text)
-import           Reflex.Dom    (Dynamic, Event, IsXhrPayload, MonadWidget,
-                                XhrRequest, XhrRequestConfig (..), XhrResponse,
-                                XhrResponseHeaders (..))
-import qualified Reflex.Dom    as R
+import           Control.Arrow      (left)
+import           Data.Aeson         (FromJSON, ToJSON)
+import qualified Data.Aeson         as Aeson
+import           Data.Default       (def)
+import qualified Data.Map.Lazy      as LM
+import           Data.Text          (Text)
+import qualified Data.Text          as T
+import qualified Data.Text.Encoding as T
+import           Reflex.Dom         (Dynamic, Event, IsXhrPayload, MonadWidget,
+                                     XhrRequest, XhrRequestConfig (..),
+                                     XhrResponse, XhrResponseHeaders (..))
+import qualified Reflex.Dom         as R
 
 postJson
-  :: forall t m a. (MonadWidget t m, ToJSON a)
+  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
-  -> m (Event t (Either Text Text))
+  -> m (Event t (Either Text b))
 postJson url input =
-  fmap getResult <$>
+  fmap getJsonResult <$>
     R.performRequestAsync (R.postJson url <$> input)
 
 delete
-  :: forall t m. MonadWidget t m
+  :: forall t m a. (MonadWidget t m)
   => Dynamic t Text
   -> Event t ()
   -> m (Event t (Either Text Text))
-delete url fire =
-  fmap getResult <$>
-    R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+delete url fire = do
+  response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+  return $ fmap getResult response
+
+getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
+getJsonResult response =
+  case getResult response of
+    Left l  -> Left l
+    Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r)
 
 getResult :: XhrResponse -> Either Text Text
 getResult response =
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
new file mode 100644
index 0000000..2910d95
--- /dev/null
+++ b/client/src/Util/Either.hs
@@ -0,0 +1,7 @@
+module Util.Either
+  ( eitherToMaybe
+  ) where
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe (Right b) = Just b
+eitherToMaybe _         = Nothing
-- 
cgit v1.2.3


From 8a28f608d8e08fba4bbe54b46804d261686c3c03 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 20:33:17 +0100
Subject: Upgrade reflex-platform

---
 client/src/Util/Ajax.hs    | 2 +-
 client/src/Util/WaitFor.hs | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 0d76638..7b65c52 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -31,7 +31,7 @@ delete
   -> Event t ()
   -> m (Event t (Either Text Text))
 delete url fire = do
-  response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+  response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
   return $ fmap getResult response
 
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 0175c95..7d5e7c5 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -13,6 +13,6 @@ waitFor
   -> Dynamic t a
   -> m (Event t b, Event t Bool)
 waitFor op start input = do
-  result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime)
+  result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime)
   let waiting = R.leftmost [ const True <$> start , const False <$> result ]
   return (result, waiting)
-- 
cgit v1.2.3


From b5244184920b4d7a8d64eada2eca21e9a6ea2df9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 20:44:12 +0100
Subject: Use waitfor with delete confirm button

---
 client/src/Util/WaitFor.hs | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 7d5e7c5..46882aa 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -9,10 +9,9 @@ import qualified Reflex.Dom as R
 waitFor
   :: forall t m a b. MonadWidget t m
   => (Event t a -> m (Event t b))
-  -> Event t ()
-  -> Dynamic t a
+  -> Event t a
   -> m (Event t b, Event t Bool)
-waitFor op start input = do
-  result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime)
-  let waiting = R.leftmost [ const True <$> start , const False <$> result ]
+waitFor op input = do
+  result <- op input >>= R.debounce (0.2 :: NominalDiffTime)
+  let waiting = R.leftmost [ const True <$> input , const False <$> result ]
   return (result, waiting)
-- 
cgit v1.2.3


From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 31 Oct 2018 19:03:19 +0100
Subject: Various fixes

---
 client/src/Util/WaitFor.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 46882aa..02edff5 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -12,6 +12,6 @@ waitFor
   -> Event t a
   -> m (Event t b, Event t Bool)
 waitFor op input = do
-  result <- op input >>= R.debounce (0.2 :: NominalDiffTime)
+  result <- op input >>= R.debounce (0.5 :: NominalDiffTime)
   let waiting = R.leftmost [ const True <$> input , const False <$> result ]
   return (result, waiting)
-- 
cgit v1.2.3


From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 1 Nov 2018 13:14:25 +0100
Subject: Implementing client side validation

---
 client/src/Util/Validation.hs | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)
 create mode 100644 client/src/Util/Validation.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
new file mode 100644
index 0000000..e2a3dcb
--- /dev/null
+++ b/client/src/Util/Validation.hs
@@ -0,0 +1,37 @@
+module Util.Validation
+  ( fireValidation
+  , fireMaybe
+  , nelError
+  ) where
+
+import           Control.Monad      (join)
+import           Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NEL
+import           Data.Text          (Text)
+import           Data.Validation    (Validation (Failure, Success))
+import qualified Data.Validation    as Validation
+import           Reflex.Dom         (Dynamic, Event, Reflex)
+import qualified Reflex.Dom         as R
+
+nelError :: Validation a b -> Validation (NonEmpty a) b
+nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success
+
+fireValidation
+  :: forall t a b c. Reflex t
+  => Dynamic t (Maybe (Validation a b))
+  -> Event t c
+  -> Event t b
+fireValidation value validate =
+  R.fmapMaybe
+    (join . fmap (Validation.validation (const Nothing) Just))
+    (R.tag (R.current value) validate)
+
+fireMaybe
+  :: forall t a b. Reflex t
+  => Dynamic t (Maybe a)
+  -> Event t b
+  -> Event t a
+fireMaybe value validate =
+  R.fmapMaybe
+    id
+    (R.tag (R.current value) validate)
-- 
cgit v1.2.3


From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 7 Aug 2019 21:27:59 +0200
Subject: Update category according to payment in add overlay

---
 client/src/Util/Validation.hs | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index e2a3dcb..fc13f36 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,7 +1,8 @@
 module Util.Validation
-  ( fireValidation
+  ( nelError
+  , toMaybe
+  , fireValidation
   , fireMaybe
-  , nelError
   ) where
 
 import           Control.Monad      (join)
@@ -16,6 +17,10 @@ import qualified Reflex.Dom         as R
 nelError :: Validation a b -> Validation (NonEmpty a) b
 nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success
 
+toMaybe :: Validation a b -> Maybe b
+toMaybe (Success s) = Just s
+toMaybe (Failure _) = Nothing
+
 fireValidation
   :: forall t a b c. Reflex t
   => Dynamic t (Maybe (Validation a b))
-- 
cgit v1.2.3


From 7c77e52faa71e43324087903c905f9d493b1dfb7 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 8 Aug 2019 21:28:22 +0200
Subject: Finish payment add modal

---
 client/src/Util/Validation.hs | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index fc13f36..f9545a4 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,6 +1,7 @@
 module Util.Validation
   ( nelError
   , toMaybe
+  , maybeError
   , fireValidation
   , fireMaybe
   ) where
@@ -21,14 +22,18 @@ toMaybe :: Validation a b -> Maybe b
 toMaybe (Success s) = Just s
 toMaybe (Failure _) = Nothing
 
+maybeError :: Validation a b -> Maybe a
+maybeError (Success _) = Nothing
+maybeError (Failure e) = Just e
+
 fireValidation
   :: forall t a b c. Reflex t
-  => Dynamic t (Maybe (Validation a b))
+  => Dynamic t (Validation a b)
   -> Event t c
   -> Event t b
 fireValidation value validate =
   R.fmapMaybe
-    (join . fmap (Validation.validation (const Nothing) Just))
+    (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
 
 fireMaybe
-- 
cgit v1.2.3


From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 21:31:27 +0200
Subject: Add smooth transitions to modal show and hide

---
 client/src/Util/WaitFor.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 02edff5..fe7b733 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -13,5 +13,5 @@ waitFor
   -> m (Event t b, Event t Bool)
 waitFor op input = do
   result <- op input >>= R.debounce (0.5 :: NominalDiffTime)
-  let waiting = R.leftmost [ const True <$> input , const False <$> result ]
+  let waiting = R.leftmost [ True <$ input , False <$ result ]
   return (result, waiting)
-- 
cgit v1.2.3


From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 11 Aug 2019 22:40:09 +0200
Subject: Add payment clone

---
 client/src/Util/Dom.hs    | 45 ----------------------------------------
 client/src/Util/Reflex.hs | 52 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 52 insertions(+), 45 deletions(-)
 delete mode 100644 client/src/Util/Dom.hs
 create mode 100644 client/src/Util/Reflex.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
deleted file mode 100644
index 55b8521..0000000
--- a/client/src/Util/Dom.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Util.Dom
-  ( divIfDyn
-  , divIfEvent
-  , divVisibleIf
-  , divClassVisibleIf
-  , getBody
-  ) where
-
-import qualified Data.Map                 as M
-import           Data.Text                (Text)
-import qualified GHCJS.DOM                as Dom
-import qualified GHCJS.DOM.Document       as Document
-import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
-import           GHCJS.DOM.Types          (Element)
-import           Reflex.Dom               (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom               as R
-
-divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
-divIfDyn cond = divIfEvent (R.updated cond)
-
-divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
-divIfEvent cond empty content =
-  R.widgetHold empty (flip fmap cond (\show ->
-    if show
-      then
-        content
-      else
-        empty))
-
-divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
-divVisibleIf cond content = divClassVisibleIf cond "" content
-
-divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
-divClassVisibleIf cond className content =
-  R.elDynAttr
-    "div"
-    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
-    content
-
-getBody :: forall t m. MonadWidget t m => m Element
-getBody = do
-  document <- Dom.currentDocumentUnchecked
-  nodelist <- Document.getElementsByTagName document ("body" :: String)
-  Just body <- nodelist `HTMLCollection.item` 0
-  return body
diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
new file mode 100644
index 0000000..c14feeb
--- /dev/null
+++ b/client/src/Util/Reflex.hs
@@ -0,0 +1,52 @@
+module Util.Reflex
+  ( visibleIfDyn
+  , visibleIfEvent
+  , divVisibleIf
+  , divClassVisibleIf
+  , flatten
+  , getBody
+  ) where
+
+import qualified Data.Map                 as M
+import           Data.Text                (Text)
+import qualified GHCJS.DOM                as Dom
+import qualified GHCJS.DOM.Document       as Document
+import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
+import           GHCJS.DOM.Types          (Element)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a)
+visibleIfDyn cond empty content =
+  R.dyn $ R.ffor cond $ \case
+    True -> content
+    False -> empty
+
+visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+visibleIfEvent cond empty content =
+  R.widgetHold empty $
+    R.ffor cond $ \case
+      True -> content
+      False -> empty
+
+divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
+divVisibleIf cond content = divClassVisibleIf cond "" content
+
+divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
+divClassVisibleIf cond className content =
+  R.elDynAttr
+    "div"
+    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
+    content
+
+flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a)
+flatten e = do
+  dyn <- R.holdDyn R.never e
+  return $ R.switchDyn dyn
+
+getBody :: forall t m. MonadWidget t m => m Element
+getBody = do
+  document <- Dom.currentDocumentUnchecked
+  nodelist <- Document.getElementsByTagName document ("body" :: String)
+  Just body <- nodelist `HTMLCollection.item` 0
+  return body
-- 
cgit v1.2.3


From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 6 Oct 2019 19:28:54 +0200
Subject: Make payment edition to work on the frontend

---
 client/src/Util/Ajax.hs | 63 ++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 46 insertions(+), 17 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 7b65c52..a4f6a74 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,24 @@
 module Util.Ajax
   ( postJson
+  , putJson
   , delete
   ) where
 
-import           Control.Arrow      (left)
-import           Data.Aeson         (FromJSON, ToJSON)
-import qualified Data.Aeson         as Aeson
-import           Data.Default       (def)
-import qualified Data.Map.Lazy      as LM
-import           Data.Text          (Text)
-import qualified Data.Text          as T
-import qualified Data.Text.Encoding as T
-import           Reflex.Dom         (Dynamic, Event, IsXhrPayload, MonadWidget,
-                                     XhrRequest, XhrRequestConfig (..),
-                                     XhrResponse, XhrResponseHeaders (..))
-import qualified Reflex.Dom         as R
+import           Control.Arrow        (left)
+import           Data.Aeson           (FromJSON, ToJSON)
+import qualified Data.Aeson           as Aeson
+import           Data.ByteString      (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Default         (def)
+import qualified Data.Map.Lazy        as LM
+import           Data.Text            (Text)
+import qualified Data.Text            as T
+import qualified Data.Text.Encoding   as T
+import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
+                                       MonadWidget, XhrRequest,
+                                       XhrRequestConfig (..), XhrResponse,
+                                       XhrResponseHeaders (..))
+import qualified Reflex.Dom           as R
 
 postJson
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
@@ -23,7 +27,16 @@ postJson
   -> m (Event t (Either Text b))
 postJson url input =
   fmap getJsonResult <$>
-    R.performRequestAsync (R.postJson url <$> input)
+    R.performRequestAsync (jsonRequest "POST" url <$> input)
+
+putJson
+  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text b))
+putJson url input =
+  fmap getJsonResult <$>
+    R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
 delete
   :: forall t m a. (MonadWidget t m)
@@ -31,8 +44,9 @@ delete
   -> Event t ()
   -> m (Event t (Either Text Text))
 delete url fire = do
-  response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
-  return $ fmap getResult response
+  fmap getResult <$>
+    (R.performRequestAsync $
+      R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
 
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
 getJsonResult response =
@@ -50,7 +64,22 @@ getResult response =
     _ -> Left "NoKey"
 
 request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
-request method url sendData =
+request method url payload =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = payload
+      }
+  in
+    R.xhrRequest method url config
+
+jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString
+jsonRequest method url payload =
   let
     config = XhrRequestConfig
       { _xhrRequestConfig_headers = def
@@ -59,7 +88,7 @@ request method url sendData =
       , _xhrRequestConfig_responseType = def
       , _xhrRequestConfig_responseHeaders = def
       , _xhrRequestConfig_withCredentials = False
-      , _xhrRequestConfig_sendData = sendData
+      , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload
       }
   in
     R.xhrRequest method url config
-- 
cgit v1.2.3


From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 12 Oct 2019 11:23:10 +0200
Subject: Implement client routing

---
 client/src/Util/Css.hs    |   9 ++
 client/src/Util/Router.hs | 266 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 275 insertions(+)
 create mode 100644 client/src/Util/Css.hs
 create mode 100644 client/src/Util/Router.hs

(limited to 'client/src/Util')

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 <> ")"
-- 
cgit v1.2.3


From 284214d3af39143fdbeca57ffa4864389e7d517a Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 14 Oct 2019 09:10:33 +0200
Subject: Show cumulative incomes per user in income page

---
 client/src/Util/Date.hs | 12 ++++++++++++
 1 file changed, 12 insertions(+)
 create mode 100644 client/src/Util/Date.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs
new file mode 100644
index 0000000..8fad881
--- /dev/null
+++ b/client/src/Util/Date.hs
@@ -0,0 +1,12 @@
+module Util.Date
+  ( utcToLocalDay
+  ) where
+
+import           Data.Time.Calendar  (Day)
+import           Data.Time.Clock     (UTCTime)
+import qualified Data.Time.LocalTime as LocalTime
+
+utcToLocalDay :: UTCTime -> IO Day
+utcToLocalDay time = do
+  timezone <- LocalTime.getCurrentTimeZone
+  return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time
-- 
cgit v1.2.3


From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 21:31:57 +0200
Subject: Load init data per page with AJAX

---
 client/src/Util/Ajax.hs | 21 +++++++++++++++------
 1 file changed, 15 insertions(+), 6 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index a4f6a74..9cd5105 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,6 +1,7 @@
 module Util.Ajax
-  ( postJson
-  , putJson
+  ( get
+  , post
+  , put
   , delete
   ) where
 
@@ -20,21 +21,29 @@ import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
                                        XhrResponseHeaders (..))
 import qualified Reflex.Dom           as R
 
-postJson
+get
+  :: forall t m a. (MonadWidget t m, FromJSON a)
+  => Event t Text
+  -> m (Event t (Either Text a))
+get url =
+  fmap getJsonResult <$>
+    R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
+
+post
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-postJson url input =
+post url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "POST" url <$> input)
 
-putJson
+put
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-putJson url input =
+put url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
-- 
cgit v1.2.3


From 33e78f2ebbf5bf7b40e7aa732cc7c019f6df3f12 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 22:08:31 +0200
Subject: Simplify page initialization

---
 client/src/Util/Ajax.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 9cd5105..47f4f3c 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,5 +1,6 @@
 module Util.Ajax
-  ( get
+  ( getNow
+  , get
   , post
   , put
   , delete
@@ -21,6 +22,14 @@ import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
                                        XhrResponseHeaders (..))
 import qualified Reflex.Dom           as R
 
+import           Loadable             (Loadable)
+import qualified Loadable
+
+getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
+getNow url = do
+  postBuild <- R.getPostBuild
+  get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent
+
 get
   :: forall t m a. (MonadWidget t m, FromJSON a)
   => Event t Text
-- 
cgit v1.2.3


From f968c8ce63e1aec119b1e6f414cf27e2c0294bcb Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 21:09:54 +0200
Subject: Delete income

---
 client/src/Util/Reflex.hs | 8 ++++++++
 1 file changed, 8 insertions(+)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
index c14feeb..9f51c5c 100644
--- a/client/src/Util/Reflex.hs
+++ b/client/src/Util/Reflex.hs
@@ -4,6 +4,7 @@ module Util.Reflex
   , divVisibleIf
   , divClassVisibleIf
   , flatten
+  , flattenTuple
   , getBody
   ) where
 
@@ -44,6 +45,13 @@ flatten e = do
   dyn <- R.holdDyn R.never e
   return $ R.switchDyn dyn
 
+
+flattenTuple
+  :: forall t m a b. MonadWidget t m
+  => Event t (Event t a, Event t b)
+  -> m (Event t a, Event t b)
+flattenTuple e = (,) <$> (flatten $ fmap fst e) <*> (flatten $ fmap snd e)
+
 getBody :: forall t m. MonadWidget t m => m Element
 getBody = do
   document <- Dom.currentDocumentUnchecked
-- 
cgit v1.2.3


From 227dcd4435b775d7dbc5ae5d3d81b589897253cc Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 2 Nov 2019 20:52:27 +0100
Subject: Implement incomes server side paging

---
 client/src/Util/Reflex.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
index 9f51c5c..aa5cebb 100644
--- a/client/src/Util/Reflex.hs
+++ b/client/src/Util/Reflex.hs
@@ -45,7 +45,6 @@ flatten e = do
   dyn <- R.holdDyn R.never e
   return $ R.switchDyn dyn
 
-
 flattenTuple
   :: forall t m a b. MonadWidget t m
   => Event t (Event t a, Event t b)
-- 
cgit v1.2.3


From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 15:47:11 +0100
Subject: Fetch the first payment date instead of every payment to get
 cumulative income

---
 client/src/Util/Date.hs | 12 ------------
 1 file changed, 12 deletions(-)
 delete mode 100644 client/src/Util/Date.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs
deleted file mode 100644
index 8fad881..0000000
--- a/client/src/Util/Date.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Util.Date
-  ( utcToLocalDay
-  ) where
-
-import           Data.Time.Calendar  (Day)
-import           Data.Time.Clock     (UTCTime)
-import qualified Data.Time.LocalTime as LocalTime
-
-utcToLocalDay :: UTCTime -> IO Day
-utcToLocalDay time = do
-  timezone <- LocalTime.getCurrentTimeZone
-  return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time
-- 
cgit v1.2.3


From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 17 Nov 2019 18:08:28 +0100
Subject: Optimize and refactor payments

---
 client/src/Util/Ajax.hs   |  5 ++++-
 client/src/Util/Either.hs |  2 +-
 client/src/Util/List.hs   | 13 -------------
 3 files changed, 5 insertions(+), 15 deletions(-)
 delete mode 100644 client/src/Util/List.hs

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 47f4f3c..dc56701 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -16,6 +16,7 @@ import qualified Data.Map.Lazy        as LM
 import           Data.Text            (Text)
 import qualified Data.Text            as T
 import qualified Data.Text.Encoding   as T
+import           Data.Time.Clock      (NominalDiffTime)
 import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
                                        MonadWidget, XhrRequest,
                                        XhrRequestConfig (..), XhrResponse,
@@ -28,7 +29,9 @@ import qualified Loadable
 getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
 getNow url = do
   postBuild <- R.getPostBuild
-  get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent
+  get (url <$ postBuild)
+    >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise
+    >>= Loadable.fromEvent
 
 get
   :: forall t m a. (MonadWidget t m, FromJSON a)
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
index 2910d95..e76bc8a 100644
--- a/client/src/Util/Either.hs
+++ b/client/src/Util/Either.hs
@@ -2,6 +2,6 @@ module Util.Either
   ( eitherToMaybe
   ) where
 
-eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe :: forall a b. Either a b -> Maybe b
 eitherToMaybe (Right b) = Just b
 eitherToMaybe _         = Nothing
diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
deleted file mode 100644
index 4e22ba8..0000000
--- a/client/src/Util/List.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Util.List
-  ( groupBy
-  ) where
-
-import           Control.Arrow ((&&&))
-import           Data.Function (on)
-import qualified Data.List     as L
-
-groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
-groupBy f =
-  map (f . head &&& id)
-    . L.groupBy ((==) `on` f)
-    . L.sortBy (compare `on` f)
-- 
cgit v1.2.3


From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 8 Dec 2019 11:39:37 +0100
Subject: Add category page

---
 client/src/Util/Ajax.hs | 28 ++++++++++++++++++++++++++--
 1 file changed, 26 insertions(+), 2 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index dc56701..dcfd402 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -2,7 +2,9 @@ module Util.Ajax
   ( getNow
   , get
   , post
+  , postAndParseResult
   , put
+  , putAndParseResult
   , delete
   ) where
 
@@ -42,20 +44,38 @@ get url =
     R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
 
 post
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text ()))
+post url input =
+  fmap checkResult <$>
+    R.performRequestAsync (jsonRequest "POST" url <$> input)
+
+postAndParseResult
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-post url input =
+postAndParseResult url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "POST" url <$> input)
 
 put
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text ()))
+put url input =
+  fmap checkResult <$>
+    R.performRequestAsync (jsonRequest "PUT" url <$> input)
+
+putAndParseResult
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-put url input =
+putAndParseResult url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
@@ -69,6 +89,10 @@ delete url fire = do
     (R.performRequestAsync $
       R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
 
+checkResult :: XhrResponse -> Either Text ()
+checkResult response =
+  () <$ getResult response
+
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
 getJsonResult response =
   case getResult response of
-- 
cgit v1.2.3


From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Jan 2020 14:03:31 +0100
Subject: Sign in with email and password

---
 client/src/Util/Validation.hs | 11 -----------
 1 file changed, 11 deletions(-)

(limited to 'client/src/Util')

diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index f9545a4..50f2468 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -3,7 +3,6 @@ module Util.Validation
   , toMaybe
   , maybeError
   , fireValidation
-  , fireMaybe
   ) where
 
 import           Control.Monad      (join)
@@ -35,13 +34,3 @@ fireValidation value validate =
   R.fmapMaybe
     (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
-
-fireMaybe
-  :: forall t a b. Reflex t
-  => Dynamic t (Maybe a)
-  -> Event t b
-  -> Event t a
-fireMaybe value validate =
-  R.fmapMaybe
-    id
-    (R.tag (R.current value) validate)
-- 
cgit v1.2.3