aboutsummaryrefslogtreecommitdiff
path: root/client/src
diff options
context:
space:
mode:
Diffstat (limited to 'client/src')
-rw-r--r--client/src/Util/Ajax.hs63
-rw-r--r--client/src/View/Payment.hs38
-rw-r--r--client/src/View/Payment/Add.hs1
-rw-r--r--client/src/View/Payment/Clone.hs1
-rw-r--r--client/src/View/Payment/Edit.hs1
-rw-r--r--client/src/View/Payment/Form.hs19
-rw-r--r--client/src/View/Payment/Table.hs13
7 files changed, 97 insertions, 39 deletions
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
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index ab83447..f2a5071 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -35,21 +35,25 @@ widget paymentIn = do
R.elClass "main" "payment" $ do
rec
let init = _paymentIn_init paymentIn
+
paymentsPerPage = 7
- savedPayments = R.leftmost
+
+ addPayment = R.leftmost
[ _headerOut_addPayment header
, _tableOut_addPayment table
]
- payments <- getPayments
+ payments <- reducePayments
(_init_payments init)
- (_savedPayment_payment <$> savedPayments)
+ (_savedPayment_payment <$> addPayment)
+ (_savedPayment_payment <$> _tableOut_editPayment table)
(_tableOut_deletePayment table)
- paymentCategories <- getPaymentCategories
+ paymentCategories <- reducePaymentCategories
(_init_paymentCategories init)
- (_savedPayment_paymentCategory <$> savedPayments)
payments
+ (_savedPayment_paymentCategory <$> addPayment)
+ (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
(_tableOut_deletePayment table)
(searchNameEvent, searchName) <-
@@ -93,28 +97,38 @@ debounceSearchName searchName = do
dynamic <- R.holdDyn "" event
return (event, dynamic)
-getPayments
+reducePayments
:: forall t m. MonadWidget t m
=> [Payment]
- -> Event t Payment
- -> Event t Payment
+ -> Event t Payment -- add payment
+ -> Event t Payment -- edit payment
+ -> Event t Payment -- delete payment
-> m (Dynamic t [Payment])
-getPayments initPayments addPayment deletePayment =
+reducePayments initPayments addPayment editPayment deletePayment =
R.foldDyn id initPayments $ R.leftmost
[ (:) <$> addPayment
+ , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
, R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
]
-getPaymentCategories
+reducePaymentCategories
:: forall t m. MonadWidget t m
=> [PaymentCategory]
- -> Event t PaymentCategory -- add payment category
-> Dynamic t [Payment] -- payments
+ -> Event t PaymentCategory -- add payment category
+ -> Event t PaymentCategory -- edit payment category
-> Event t Payment -- delete payment
-> m (Dynamic t [PaymentCategory])
-getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment =
+reducePaymentCategories
+ initPaymentCategories
+ payments
+ addPaymentCategory
+ editPaymentCategory
+ deletePayment
+ =
R.foldDyn id initPaymentCategories $ R.leftmost
[ (:) <$> addPaymentCategory
+ , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
, R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
]
where
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 88806bc..e83dba9 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -46,6 +46,7 @@ view input cancel = do
, Form._input_category = -1
, Form._input_frequency = frequency
, Form._input_mkPayload = CreatePayment
+ , Form._input_httpMethod = Form.Post
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 5624f6c..922e89c 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -49,6 +49,7 @@ view input cancel = do
, Form._input_category = category
, Form._input_frequency = _payment_frequency payment
, Form._input_mkPayload = CreatePayment
+ , Form._input_httpMethod = Form.Post
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 5020e57..9c11af0 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -44,6 +44,7 @@ view input cancel = do
, Form._input_category = category
, Form._input_frequency = _payment_frequency payment
, Form._input_mkPayload = EditPayment (_payment_id payment)
+ , Form._input_httpMethod = Form.Put
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index ba54957..9889638 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,6 +1,7 @@
module View.Payment.Form
( view
, Input(..)
+ , HttpMethod(..)
, Output(..)
) where
@@ -46,8 +47,11 @@ data Input t p = Input
, _input_category :: CategoryId
, _input_frequency :: Frequency
, _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p
+ , _input_httpMethod :: HttpMethod
}
+data HttpMethod = Put | Post
+
data Output t = Output
{ _output_hide :: Event t ()
, _output_addPayment :: Event t SavedPayment
@@ -139,7 +143,7 @@ view input = do
})
(addPayment, waiting) <- WaitFor.waitFor
- (Ajax.postJson "/payment")
+ (ajax "/payment")
(ValidationUtil.fireValidation payment confirm)
return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
@@ -150,14 +154,19 @@ view input = do
}
where
- frequencies = M.fromList
- [ (Punctual, Msg.get Msg.Payment_PunctualMale)
- , (Monthly, Msg.get Msg.Payment_MonthlyMale)
- ]
+ frequencies =
+ M.fromList
+ [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+ , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+ ]
categories = M.fromList . flip map (_input_categories input) $ \c ->
(_category_id c, _category_name c)
+ ajax =
+ case _input_httpMethod input of
+ Post -> Ajax.postJson
+ Put -> Ajax.putJson
findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
findCategory paymentName =
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index f2b8870..40bc864 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -44,6 +44,7 @@ data TableIn t = TableIn
data TableOut t = TableOut
{ _tableOut_addPayment :: Event t SavedPayment
+ , _tableOut_editPayment :: Event t SavedPayment
, _tableOut_deletePayment :: Event t Payment
}
@@ -51,7 +52,7 @@ widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
widget tableIn = do
R.divClass "table" $ do
- (addPayment, deletePayment) <- R.divClass "lines" $ do
+ (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do
R.divClass "header" $ do
R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -66,8 +67,9 @@ widget tableIn = do
(R.simpleList paymentRange (paymentRow init paymentCategories))
return $
- ( R.switch . R.current . fmap (R.leftmost . map fst) $ result
- , R.switch . R.current . fmap (R.leftmost . map snd) $ result
+ ( 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
)
ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
@@ -75,6 +77,7 @@ widget tableIn = do
return $ TableOut
{ _tableOut_addPayment = addPayment
+ , _tableOut_editPayment = editPayment
, _tableOut_deletePayment = deletePayment
}
@@ -98,7 +101,7 @@ paymentRow
=> Init
-> Dynamic t [PaymentCategory]
-> Dynamic t Payment
- -> m (Event t SavedPayment, Event t Payment)
+ -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
paymentRow init paymentCategories payment =
R.divClass "row" $ do
@@ -200,7 +203,7 @@ paymentRow init paymentCategories payment =
}
}
- return $ (paymentCloned, paymentDeleted)
+ return $ (paymentCloned, paymentEdited, paymentDeleted)
findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
findCategory categories paymentCategories paymentName = do
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 00:28:56 +0000