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