aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal6
-rw-r--r--client/src/Component/Form.hs2
-rw-r--r--client/src/Component/Modal.hs33
-rw-r--r--client/src/Component/Select.hs2
-rw-r--r--client/src/Util/Ajax.hs67
-rw-r--r--client/src/Util/Dom.hs36
-rw-r--r--client/src/View/Payment/Add.hs6
-rw-r--r--client/src/View/Payment/Delete.hs40
-rw-r--r--client/src/View/Payment/Header.hs4
-rw-r--r--client/src/View/Payment/Table.hs2
-rw-r--r--client/src/View/SignIn.hs6
11 files changed, 143 insertions, 61 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 16:06:35 +0000