diff options
| -rw-r--r-- | ISSUES.md | 51 | ||||
| -rw-r--r-- | README.md | 53 | ||||
| -rw-r--r-- | client/src/Util/Ajax.hs | 63 | ||||
| -rw-r--r-- | client/src/View/Payment.hs | 38 | ||||
| -rw-r--r-- | client/src/View/Payment/Add.hs | 1 | ||||
| -rw-r--r-- | client/src/View/Payment/Clone.hs | 1 | ||||
| -rw-r--r-- | client/src/View/Payment/Edit.hs | 1 | ||||
| -rw-r--r-- | client/src/View/Payment/Form.hs | 19 | ||||
| -rw-r--r-- | client/src/View/Payment/Table.hs | 13 | ||||
| -rw-r--r-- | server/src/Controller/Payment.hs | 6 | ||||
| -rw-r--r-- | server/src/Persistence/Payment.hs | 6 | ||||
| -rw-r--r-- | server/src/Persistence/PaymentCategory.hs | 2 |
12 files changed, 157 insertions, 97 deletions
diff --git a/ISSUES.md b/ISSUES.md new file mode 100644 index 0000000..9ee077d --- /dev/null +++ b/ISSUES.md @@ -0,0 +1,51 @@ +# Fix + +- When clicking on an input label, focus to the input + +# Payment view + +- Remove unused payment category after payment edit on frontend +- Remove old validation, use client validation on the backend +- Add icon tooltip ? +- auto focus on first input when payment modal is open + +# Income view + +… + +# Category view + +… + +# Stat view + +… + +# Features + +- HTTP error message +- Use only one loader +- Login with email and password +- search payments by: + - category, + - date. + +# Code + +- remove client warning messages +- Use BEM style +- Move the CSS out from the index page +- Test exceedingPayers +- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) + +# DB + +- Add DB indexes + +# Tooling + +- deploy command +- migration diff (use flyway?). +- use ghcid +- set up fast deploy +- pin nixpkgs @@ -56,55 +56,6 @@ See [application.conf](application.conf). - [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html) - [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html) -## TODO +## Issues -### Fix - -- When clicking on an input label, focus to the input - -### Payment view - -- Edit a payment -- Possibly remove payment category after payment edit (frontend) -- Remove old validation, use client validation on the backend -- Add icon tooltip ? - -### Income view - -… - -### Category view - -… - -### Stat view - -… - -#### Bonus - -- HTTP error message -- Use only one loader -- Login with email and password -- search payments by: - - category, - - date. - -### Code - -- remove client warning messages -- Use BEM style -- Move the CSS out from the index page -- Add tests about exceedingPayers -- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) - -### DB - -- Add DB indexes - -### Tooling - -- deploy command -- migration diff (use flyway?). -- utiliser ghcid -- set up fast deploy +See [ISSUES.md](ISSUES.md). 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 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c700240..38c1c19 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -47,10 +47,10 @@ edit (EditPayment paymentId name cost date category frequency) = result <- liftIO . Query.run $ do editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency case editedPayment of - Just p -> do + Just (old, new) -> do pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused name - return $ Just (p, pc) + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return $ Just (new, pc) Nothing -> return Nothing case result of diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index b3f2b2e..bcd7eb8 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -129,13 +129,13 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment) +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment)) edit userId paymentId name cost date frequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> SQLite.query conn - "SELECT * FROM payment WHERE id = ? and userId = ?" + "SELECT * FROM payment WHERE id = ? and user_id = ?" (paymentId, userId) case mbPayment of Just payment -> do @@ -163,7 +163,7 @@ edit userId paymentId name cost date frequency = , paymentId , userId ) - return . Just $ Payment + return . Just . (,) payment $ Payment { _payment_id = paymentId , _payment_user = userId , _payment_name = name diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 7dc363c..46be7f5 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -84,6 +84,6 @@ deleteIfUnused name = Query (\conn -> SQLite.execute conn - "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)" + "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)" (name, name) ) >> return () |