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

---
 client/client.cabal                   |  1 +
 client/src/Component/ConfirmDialog.hs | 49 +++++++++++++++++++++++++++++++
 client/src/Component/Table.hs         | 42 ++++++++++++++++++++-------
 client/src/Util/Reflex.hs             |  8 ++++++
 client/src/View/App.hs                |  3 +-
 client/src/View/Income/Add.hs         | 22 +++++++-------
 client/src/View/Income/Header.hs      |  6 ++--
 client/src/View/Income/Income.hs      | 33 +++++++++++++++------
 client/src/View/Income/Table.hs       | 54 +++++++++++++++++++++++------------
 client/src/View/Payment/Delete.hs     |  1 -
 10 files changed, 164 insertions(+), 55 deletions(-)
 create mode 100644 client/src/Component/ConfirmDialog.hs

(limited to 'client')

diff --git a/client/client.cabal b/client/client.cabal
index c78ed87..6163ab0 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -46,6 +46,7 @@ Executable client
 
   other-modules:
     Component.Button
+    Component.ConfirmDialog
     Component.Form
     Component.Input
     Component.Link
diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs
new file mode 100644
index 0000000..50e30ed
--- /dev/null
+++ b/client/src/Component/ConfirmDialog.hs
@@ -0,0 +1,49 @@
+module Component.ConfirmDialog
+  ( In(..)
+  , view
+  ) where
+
+import           Data.Text        (Text)
+import           Reflex.Dom       (Event, MonadWidget)
+import qualified Reflex.Dom       as R
+
+import qualified Common.Msg       as Msg
+import qualified Component.Button as Button
+import qualified Component.Modal  as Modal
+import qualified Util.Either      as EitherUtil
+import qualified Util.WaitFor     as WaitFor
+
+data In t m a = In
+  { _in_header  :: Text
+  , _in_confirm :: Event t () -> m (Event t a)
+  }
+
+view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a
+view input _ =
+  R.divClass "confirm" $ do
+    R.divClass "confirmHeader" $
+      R.text $ _in_header input
+
+    R.divClass "confirmContent" $ do
+      (confirm, cancel) <- R.divClass "buttons" $ do
+
+        cancel <- Button._out_clic <$> (Button.view $
+          (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { Button._in_class = R.constDyn "undo" })
+
+        rec
+          confirm <- Button._out_clic <$> (Button.view $
+            (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { Button._in_class = R.constDyn "confirm"
+              , Button._in_submit = True
+              , Button._in_waiting = waiting
+              })
+
+          (result, waiting) <- WaitFor.waitFor (_in_confirm input) confirm
+
+        return (result, cancel)
+
+      return $
+        ( R.leftmost [ cancel, () <$ confirm ]
+        , confirm
+        )
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 5819f45..b3c70a0 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -20,11 +20,14 @@ data In m t h r a = In
   , _in_cell        :: h -> r -> Text
   , _in_perPage     :: Int
   , _in_resetPage   :: Event t ()
-  , _in_cloneModal  :: Dynamic t r -> Modal.Content t m a
+  , _in_cloneModal  :: r -> Modal.Content t m a
+  , _in_deleteModal :: r -> Modal.Content t m a
+  , _in_isOwner     :: r -> Bool
   }
 
 data Out t a = Out
-  { _out_add :: Event t a
+  { _out_add    :: Event t a
+  , _out_delete :: Event t a
   }
 
 view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h)  => In m t h r a -> m (Out t a)
@@ -39,6 +42,7 @@ view input =
               _in_headerLabel input header
 
           R.divClass "cell" $ R.blank
+          R.divClass "cell" $ R.blank
 
         let rows = getRange
               (_in_perPage input)
@@ -60,25 +64,41 @@ view input =
             cloned <-
               Modal.view $ Modal.In
                 { Modal._in_show    = clone
-                , Modal._in_content = _in_cloneModal input r
+                , Modal._in_content = \curtainClick ->
+                  (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick)
+                    >>= ReflexUtil.flattenTuple
+                }
+
+            let isOwner = R.ffor r (_in_isOwner input)
+
+            delete <-
+              R.divClass "cell button" $
+                ReflexUtil.divVisibleIf isOwner $
+                  Button._out_clic <$> (Button.view $
+                    Button.defaultIn Icon.delete)
+
+            deleted <-
+              Modal.view $ Modal.In
+                { Modal._in_show    = delete
+                , Modal._in_content = \curtainClick ->
+                  (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick)
+                    >>= ReflexUtil.flattenTuple
                 }
 
-            return cloned
+            return (cloned, deleted)
 
       pages <- Pages.view $ Pages.In
-        { Pages._in_total = length <$> (_in_rows input)
+        { Pages._in_total = length <$> _in_rows input
         , Pages._in_perPage = _in_perPage input
         , Pages._in_reset = _in_resetPage input
         }
 
-      -- return $
-      --   ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
-      --   , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
-      --   , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
-      --   )
+    let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result
+        delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result
 
     return $ Out
-      { _out_add = R.switch . R.current . fmap R.leftmost $ result
+      { _out_add = add
+      , _out_delete = delete
       }
 
 getRange :: forall a. Int -> Int -> [a] -> [a]
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
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index e0a52e2..1e26417 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -69,7 +69,8 @@ signedWidget init route = do
     IncomeRoute -> do
       incomeInit <- Income.init
       Income.view $ Income.In
-        { Income._in_currency = _init_currency init
+        { Income._in_currentUser = _init_currentUser init
+        , Income._in_currency = _init_currency init
         , Income._in_init = incomeInit
         }
 
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
index d07bd45..7780d73 100644
--- a/client/src/View/Income/Add.hs
+++ b/client/src/View/Income/Add.hs
@@ -7,19 +7,18 @@ import           Control.Monad.IO.Class (liftIO)
 import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
 import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Dynamic, MonadWidget)
-import qualified Reflex.Dom             as R
+import           Reflex.Dom             (MonadWidget)
 
 import           Common.Model           (CreateIncomeForm (..), Income (..))
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as TimeUtil
+import qualified Component.Form
 import qualified Component.Modal        as Modal
 import qualified Util.Ajax              as Ajax
-import qualified Util.Reflex            as ReflexUtil
 import qualified View.Income.Form       as Form
 
 data In t = In
-  { _in_income :: Dynamic t (Maybe Income)
+  { _in_income :: Maybe Income
   }
 
 view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income
@@ -27,18 +26,17 @@ view input cancel = do
 
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
-  form <- R.dyn $ do
-    income <- _in_income input
-    return $ Form.view $ Form.In
+  let amount =
+        Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input))
+
+  form <-
+    Component.Form.view $ Form.view $ Form.In
       { Form._in_cancel = cancel
       , Form._in_headerLabel = Msg.get Msg.Income_AddLong
-      , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income)
+      , Form._in_amount = amount
       , Form._in_date = currentDay
       , Form._in_mkPayload = CreateIncomeForm
       , Form._in_ajax = Ajax.post
       }
 
-  hide <- ReflexUtil.flatten (Form._out_hide <$> form)
-  addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form)
-
-  return (hide, addIncome)
+  return (Form._out_hide form, Form._out_addIncome form)
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 0360d1f..f17e774 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -29,7 +29,7 @@ data In t = In
   }
 
 data Out t = Out
-  { _out_addIncome :: Event t Income
+  { _out_add :: Event t Income
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
@@ -72,11 +72,11 @@ view input =
 
       addIncome <- Modal.view $ Modal.In
         { Modal._in_show    = addIncome
-        , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing }
+        , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing }
         }
 
       return $ Out
-        { _out_addIncome = addIncome
+        { _out_add = addIncome
         }
 
   where
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index b97613d..2784cac 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -6,10 +6,10 @@ module View.Income.Income
 
 import           Data.Aeson         (FromJSON)
 import           Prelude            hiding (init)
-import           Reflex.Dom         (Dynamic, MonadWidget)
+import           Reflex.Dom         (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom         as R
 
-import           Common.Model       (Currency)
+import           Common.Model       (Currency, Income (..), UserId)
 
 import           Loadable           (Loadable (..))
 import qualified Loadable
@@ -19,8 +19,9 @@ import           View.Income.Init   (Init (..))
 import qualified View.Income.Table  as Table
 
 data In t = In
-  { _in_currency :: Currency
-  , _in_init     :: Dynamic t (Loadable Init)
+  { _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  , _in_init        :: Dynamic t (Loadable Init)
   }
 
 init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
@@ -42,13 +43,14 @@ view input = do
 
       rec
         let addIncome = R.leftmost
-              [ Header._out_addIncome header
-              , Table._out_addIncome table
+              [ Header._out_add header
+              , Table._out_add table
               ]
-        incomes <- R.foldDyn
-          (:)
+
+        incomes <- reduceIncomes
           (_init_incomes init)
           addIncome
+          (Table._out_delete table)
 
         header <- Header.view $ Header.In
           { Header._in_init = init
@@ -57,7 +59,8 @@ view input = do
           }
 
         table <- Table.view $ Table.In
-          { Table._in_init = init
+          { Table._in_currentUser = _in_currentUser input
+          , Table._in_init = init
           , Table._in_currency = _in_currency input
           , Table._in_incomes = incomes
           }
@@ -65,3 +68,15 @@ view input = do
       return ()
 
   return ()
+
+reduceIncomes
+  :: forall t m. MonadWidget t m
+  => [Income]
+  -> Event t Income -- add income
+  -> Event t Income -- delete income
+  -> m (Dynamic t [Income])
+reduceIncomes initIncomes add delete =
+  R.foldDyn id initIncomes $ R.leftmost
+    [ (:) <$> add
+    , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id))
+    ]
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 358cb17..16ebf7c 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -4,29 +4,36 @@ module View.Income.Table
   , Out(..)
   ) where
 
-import qualified Data.List          as L
-import qualified Data.Maybe         as Maybe
-import           Data.Text          (Text)
-import           Reflex.Dom         (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom         as R
+import qualified Data.List               as L
+import qualified Data.Maybe              as Maybe
+import           Data.Text               (Text)
+import qualified Data.Text               as T
+import           Reflex.Dom              (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom              as R
 
-import           Common.Model       (Currency, Income (..), User (..))
-import qualified Common.Model       as CM
-import qualified Common.Msg         as Msg
-import qualified Common.View.Format as Format
+import           Common.Model            (Currency, Income (..), User (..),
+                                          UserId)
+import qualified Common.Model            as CM
+import qualified Common.Msg              as Msg
+import qualified Common.View.Format      as Format
 
-import qualified Component.Table    as Table
-import qualified View.Income.Add    as Add
-import           View.Income.Init   (Init (..))
+import qualified Component.ConfirmDialog as ConfirmDialog
+import qualified Component.Table         as Table
+import qualified Util.Ajax               as Ajax
+import qualified Util.Either             as EitherUtil
+import qualified View.Income.Add         as Add
+import           View.Income.Init        (Init (..))
 
 data In t = In
-  { _in_init     :: Init
-  , _in_currency :: Currency
-  , _in_incomes  :: Dynamic t [Income]
+  { _in_currentUser :: UserId
+  , _in_init        :: Init
+  , _in_currency    :: Currency
+  , _in_incomes     :: Dynamic t [Income]
   }
 
 data Out t = Out
-  { _out_addIncome :: Event t Income
+  { _out_add    :: Event t Income
+  , _out_delete :: Event t Income
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
@@ -40,12 +47,23 @@ view input = do
     , Table._in_resetPage = R.never
     , Table._in_cloneModal = \income ->
       Add.view $ Add.In
-        { Add._in_income = Just <$> income
+        { Add._in_income = Just income
         }
+    , Table._in_deleteModal = \income ->
+      ConfirmDialog.view $ ConfirmDialog.In
+        { ConfirmDialog._in_header  = Msg.get Msg.Income_DeleteConfirm
+        , ConfirmDialog._in_confirm = \e -> do
+          res <- Ajax.delete
+            (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income])
+            e
+          return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+        }
+    , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId
     }
 
   return $ Out
-    { _out_addIncome = Table._out_add table
+    { _out_add = Table._out_add table
+    , _out_delete = Table._out_delete table
     }
 
 data Header
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 471463c..e5e7219 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -12,7 +12,6 @@ import           Common.Model     (Payment (..))
 import qualified Common.Msg       as Msg
 import qualified Component.Button as Button
 import qualified Component.Modal  as Modal
-import qualified Component.Modal  as Modal
 import qualified Util.Ajax        as Ajax
 import qualified Util.Either      as EitherUtil
 import qualified Util.WaitFor     as WaitFor
-- 
cgit v1.2.3