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

---
 client/client.cabal               |  6 ++--
 client/src/Component/Form.hs      |  2 +-
 client/src/Component/Modal.hs     | 33 ++++++++++++-------
 client/src/Component/Select.hs    |  2 +-
 client/src/Util/Ajax.hs           | 67 +++++++++++++++++++++++++++++----------
 client/src/Util/Dom.hs            | 36 ++++++++++++++++++---
 client/src/View/Payment/Add.hs    |  6 ++--
 client/src/View/Payment/Delete.hs | 40 +++++++++++++----------
 client/src/View/Payment/Header.hs |  4 +--
 client/src/View/Payment/Table.hs  |  2 +-
 client/src/View/SignIn.hs         |  6 ++--
 11 files changed, 143 insertions(+), 61 deletions(-)

(limited to 'client')

diff --git a/client/client.cabal b/client/client.cabal
index 0aec05f..26ad2ec 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -10,7 +10,7 @@ Cabal-version:       >=1.10
 
 Executable client
   Main-Is:           Main.hs
-  Ghc-options:       -Wall -Werror
+  -- Ghc-options:       -Wall -Werror
   Hs-source-dirs:    src
   Default-language:  Haskell2010
 
@@ -22,10 +22,12 @@ Executable client
 
   Build-depends:
     aeson
-    , base >=4.9 && <4.11
+    , base >=4.9 && <5
     , bytestring
     , common
     , containers
+    , data-default
+    , ghcjs-dom-jsffi
     , jsaddle-dom
     , reflex-dom
     , text
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
index 0a89c6e..6ea02fa 100644
--- a/client/src/Component/Form.hs
+++ b/client/src/Component/Form.hs
@@ -6,7 +6,7 @@ import qualified Data.Map   as M
 import           Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-form :: forall t m a. (MonadWidget t m) => m a -> m a
+form :: forall t m a. MonadWidget t m => m a -> m a
 form content =
   R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
     content
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 1d70c90..72091c9 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,14 +1,19 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Component.Modal
   ( ModalIn(..)
   , ModalOut(..)
   , modal
   ) where
 
-import qualified Data.Map   as M
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
+import           Control.Monad    (void)
+import qualified Data.Map         as M
+import qualified Data.Map.Lazy    as LM
+import           Data.Text        (Text)
+import qualified GHCJS.DOM.Node   as Node
+import           Reflex.Dom       (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom       as R
+import qualified Reflex.Dom.Class as R
+
+import qualified Util.Dom         as Dom
 
 data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
@@ -29,16 +34,22 @@ modal modalIn = do
       , False <$ curtainClick
       ]
 
-    let attr = flip fmap showModal (\s -> M.fromList $
-          [ ("style", if s then "display:block" else "display:none")
-          , ("class", "modal")
-          ])
-
-    (curtainClick, content) <- R.elDynAttr "div" attr $ do
+    (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do
       (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
       cont <- R.divClass "modalContent" $ _modalIn_content modalIn
       return (R.domEvent R.Click curtain, cont)
 
+  body <- Dom.getBody
+  let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn)
+  R.performEvent_ $ void `fmap` moveBackdrop
+
   return $ ModalOut
     { _modalOut_content = content
     }
+
+getAttributes :: Bool -> LM.Map Text Text
+getAttributes show =
+  M.fromList $
+    [ ("style", if show then "display:block" else "display:none")
+    , ("class", "modal")
+    ]
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 876548e..17a4958 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -19,7 +19,7 @@ data SelectOut t a = SelectOut
   { _selectOut_value :: Dynamic t a
   }
 
-select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a)
+select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a)
 select selectIn =
   R.divClass "selectInput" $ do
     R.el "label" $ R.text (_selectIn_label selectIn)
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
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 5ff09dd..8b1b56e 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -23,7 +23,7 @@ import           Component              (ButtonIn (..), InputIn (..),
                                          SelectOut (..))
 import qualified Component              as Component
 import qualified Util.Ajax              as Ajax
-import qualified Util.WaitFor           as Util
+import qualified Util.WaitFor           as WaitFor
 
 data AddIn = AddIn
   { _addIn_categories :: [Category]
@@ -83,8 +83,8 @@ view addIn = do
               , _buttonIn_submit = True
               })
 
-          (_, waiting) <- Util.waitFor
-            (Ajax.post "/payment")
+          (_, waiting) <- WaitFor.waitFor
+            (Ajax.postJson "/payment")
             validate
             payment
 
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index a1be16d..03cf267 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,24 +4,27 @@ module View.Payment.Delete
   , DeleteOut(..)
   ) where
 
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import qualified Common.Msg as Msg
-import           Component  (ButtonIn (..), ButtonOut (..))
-import qualified Component  as Component
--- import qualified Util.Ajax              as Ajax
--- import qualified Util.WaitFor           as Util
-
-data DeleteIn = DeleteIn
-  {}
+import qualified Data.Text            as T
+import           Reflex.Dom           (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom           as R
+
+import           Common.Model.Payment (PaymentId)
+import qualified Common.Msg           as Msg
+import           Component            (ButtonIn (..), ButtonOut (..))
+import qualified Component            as Component
+import qualified Util.Ajax            as Ajax
+-- import qualified Util.WaitFor           as WaitFor
+
+data DeleteIn t = DeleteIn
+  { _deleteIn_id :: Dynamic t PaymentId
+  }
 
 data DeleteOut t = DeleteOut
   { _deleteOut_cancel :: Event t ()
   }
 
-view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
-view _ =
+view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
+view deleteIn =
   R.divClass "delete" $ do
     R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
 
@@ -29,14 +32,19 @@ view _ =
 
       cancel <- R.divClass "buttons" $ do
         rec
-          _ <- Component._buttonOut_clic <$> (Component.button $
+          confirm <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
               { _buttonIn_class = R.constDyn "confirm"
               , _buttonIn_submit = True
               })
 
-          -- (_, waiting) <- Util.waitFor
-          --   (Ajax.post "/payment")
+          let url = flip fmap (_deleteIn_id deleteIn) (\id ->
+                  T.concat ["/payment/", T.pack . show $ id]
+                )
+          Ajax.delete url confirm
+
+          -- (_, waiting) <- WaitFor.waitFor
+          --   (Ajax.delete "/payment")
           --   validate
           --   payment
 
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index fd46c25..be7f6d5 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -86,7 +86,7 @@ payerAndAdd incomes payments users categories currency = do
               R.text "+ "
               R.text . Format.price currency $ _exceedingPayer_amount p
         )
-    addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn
+    addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
@@ -95,7 +95,7 @@ payerAndAdd incomes payments users categories currency = do
       })
     rec
       modalOut <- Component.modal $ ModalIn
-        { _modalIn_show    = addPayment
+        { _modalIn_show    = addPaymentClic
         , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
         , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 23d7225..13cedda 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -118,7 +118,7 @@ paymentRow init payment =
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
         , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
-        , _modalIn_content = Delete.view (DeleteIn {})
+        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
         }
     return ()
 
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 21d0fcc..24e5be0 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -16,7 +16,7 @@ import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
                                InputOut (..))
 import qualified Component    as Component
 import qualified Util.Ajax    as Ajax
-import qualified Util.WaitFor as Util
+import qualified Util.WaitFor as WaitFor
 
 data SignInMessage =
   SuccessMessage Text
@@ -43,8 +43,8 @@ view signInMessage =
             , _buttonIn_submit = True
             }
 
-        (signInResult, waiting) <- Util.waitFor
-          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+        (signInResult, waiting) <- WaitFor.waitFor
+          (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email))
           (_buttonOut_clic button)
           (_inputOut_value input)
 
-- 
cgit v1.2.3