diff options
47 files changed, 778 insertions, 268 deletions
diff --git a/client/client.cabal b/client/client.cabal index 78ea7d3..227aed2 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -56,6 +56,7 @@ Executable client Component.Pages Component.Select Component.Table + Component.Tag Loadable Model.Route Util.Ajax @@ -73,6 +74,10 @@ Executable client View.Income.Income View.Income.Reducer View.Income.Table + View.Category.Form + View.Category.Category + View.Category.Reducer + View.Category.Table View.NotFound View.Payment.Form View.Payment.HeaderForm diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs index 50e30ed..cf26593 100644 --- a/client/src/Component/ConfirmDialog.hs +++ b/client/src/Component/ConfirmDialog.hs @@ -13,12 +13,12 @@ import qualified Component.Modal as Modal import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data In t m a = In +data In t m = In { _in_header :: Text - , _in_confirm :: Event t () -> m (Event t a) + , _in_confirm :: Event t () -> m (Event t ()) } -view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a +view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m view input _ = R.divClass "confirm" $ do R.divClass "confirmHeader" $ diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 08f2e74..46d3f64 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -20,14 +20,14 @@ import qualified Reflex.Dom.Class as R import qualified Util.Reflex as ReflexUtil -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) -type Content t m a = Event t () -> m (Event t (), Event t a) +type Content t m = Event t () -> m (Event t (), Event t ()) -data In t m a = In +data In t m = In { _in_show :: Event t () - , _in_content :: Content t m a + , _in_content :: Content t m } -view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a) +view :: forall t m a. MonadWidget t m => In t m -> m (Event t ()) view input = do rec let show = Show <$ (_in_show input) diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index f5bf287..c56ff88 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -20,20 +20,20 @@ import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data In m t a b e = In +data In m t a e = In { _in_headerLabel :: Text , _in_form :: m (Dynamic t (Validation e a)) - , _in_ajax :: Event t a -> m (Event t (Either Text b)) + , _in_ajax :: Event t a -> m (Event t (Either Text ())) } -data Out t a = Out +data Out t = Out { _out_hide :: Event t () , _out_cancel :: Event t () , _out_confirm :: Event t () - , _out_validate :: Event t a + , _out_validate :: Event t () } -view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b) +view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t) view input = R.divClass "form" $ do R.divClass "formHeader" $ diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 2869c2d..f82cfa6 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -14,23 +14,23 @@ import qualified Component.Modal as Modal import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data In m t h r a b c = In +data In m t h r = In { _in_headerLabel :: h -> Text , _in_rows :: [r] , _in_cell :: h -> r -> m () - , _in_cloneModal :: r -> Modal.Content t m a - , _in_editModal :: r -> Modal.Content t m b - , _in_deleteModal :: r -> Modal.Content t m c + , _in_cloneModal :: r -> Modal.Content t m + , _in_editModal :: r -> Modal.Content t m + , _in_deleteModal :: r -> Modal.Content t m , _in_isOwner :: r -> Bool } -data Out t a b c = Out - { _out_add :: Event t a - , _out_edit :: Event t b - , _out_delete :: Event t c +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } -view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c) +view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In m t h r -> m (Out t) view input = R.divClass "table" $ do rec diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs new file mode 100644 index 0000000..f75b8d3 --- /dev/null +++ b/client/src/Component/Tag.hs @@ -0,0 +1,27 @@ +module Component.Tag + ( In(..) + , view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +data In = In + { _in_text :: Text + , _in_color :: Text + } + +view :: forall t m a. MonadWidget t m => In -> m () +view input = + R.elAttr "span" attrs $ + R.text $ _in_text input + + where + attrs = + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _in_color input ]) + ] diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs index 420fe05..63e5d10 100644 --- a/client/src/Model/Route.hs +++ b/client/src/Model/Route.hs @@ -5,5 +5,6 @@ module Model.Route data Route = RootRoute | IncomeRoute + | CategoryRoute | NotFoundRoute deriving (Eq, Show) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index dc56701..dcfd402 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -2,7 +2,9 @@ module Util.Ajax ( getNow , get , post + , postAndParseResult , put + , putAndParseResult , delete ) where @@ -42,20 +44,38 @@ get url = R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String "")) post + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +post url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "POST" url <$> input) + +postAndParseResult :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -post url input = +postAndParseResult url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "POST" url <$> input) put + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +put url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) + +putAndParseResult :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -put url input = +putAndParseResult url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "PUT" url <$> input) @@ -69,6 +89,10 @@ delete url fire = do (R.performRequestAsync $ R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) +checkResult :: XhrResponse -> Either Text () +checkResult response = + () <$ getResult response + getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a getJsonResult response = case getResult response of diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 2b346af..460d499 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,23 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), InitResult (..), - UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), InitResult (..), + UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -72,6 +73,13 @@ signedWidget init route = do , Income._in_users = _init_users init } + CategoryRoute -> + Category.view $ Category.In + { Category._in_currentUser = _init_currentUser init + , Category._in_currency = _init_currency init + , Category._in_users = _init_users init + } + NotFoundRoute -> NotFound.view @@ -87,5 +95,8 @@ getRoute = do ["income"] -> IncomeRoute + ["category"] -> + CategoryRoute + _ -> NotFoundRoute diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs new file mode 100644 index 0000000..77a331a --- /dev/null +++ b/client/src/View/Category/Category.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ExplicitForAll #-} + +module View.Category.Category + ( view + , In(..) + ) where + +import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, CategoryPage (..), Currency, + User, UserId) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Category.Form as Form +import qualified View.Category.Reducer as Reducer +import qualified View.Category.Table as Table + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + rec + categoryPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_addCategory = R.leftmost [ headerAddCategory, tableAddCategory ] + , Reducer._in_editCategory = editCategory + , Reducer._in_deleteCategory = deleteCategory + } + + let eventFromResult :: forall a. ((Event t (), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten $ (Maybe.fromMaybe R.never . fmap op) <$> result + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + headerAddCategory <- eventFromResult $ (\(a, _, _) -> a) + tableAddCategory <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editCategory <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- Loadable.viewShowValueWhileLoading categoryPage $ + \(CategoryPage page categories count) -> do + header <- headerView + + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_categories = categories + , Table._in_users = _in_users input + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (header, table, pages) + + return () + +headerView :: forall t m. MonadWidget t m => m (Event t ()) +headerView = + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Form.hs b/client/src/View/Category/Form.hs new file mode 100644 index 0000000..d91fc2e --- /dev/null +++ b/client/src/View/Category/Form.hs @@ -0,0 +1,117 @@ +module View.Category.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Category as CategoryValidation +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax + +data In = In + { _in_operation :: Operation + } + +data Operation + = New + | Clone Category + | Edit Category + +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m +view input cancel = do + + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/category" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text Value)) + form reset confirm = do + name <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Name + , Input._in_initialValue = name + , Input._in_validation = CategoryValidation.name + }) + (name <$ reset) + confirm) + + color <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Color + , Input._in_initialValue = color + , Input._in_inputType = "color" + , Input._in_hasResetButton = False + , Input._in_validation = CategoryValidation.color + }) + (color <$ reset) + confirm) + + return $ do + n <- name + c <- color + return . V.Success $ mkPayload n c + + op = _in_operation input + + name = + case op of + New -> "" + Clone c -> _category_name c + Edit c -> _category_name c + + color = + case op of + New -> "" + Clone c -> _category_color c + Edit c -> _category_color c + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + headerLabel = + case op of + Edit _ -> Msg.get Msg.Category_Edit + _ -> Msg.get Msg.Category_Add + + mkPayload = + case op of + Edit i -> \a b -> Aeson.toJSON $ EditCategoryForm (_category_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateCategoryForm a b diff --git a/client/src/View/Category/Reducer.hs b/client/src/View/Category/Reducer.hs new file mode 100644 index 0000000..5ad0ddb --- /dev/null +++ b/client/src/View/Category/Reducer.hs @@ -0,0 +1,59 @@ +module View.Category.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CategoryPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_addCategory :: Event t a + , _in_editCategory :: Event t b + , _in_deleteCategory :: Event t c + } + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable CategoryPage)) +reducer input = do + + postBuild <- R.getPostBuild + + currentPage <- R.holdDyn 1 (_in_page input) + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_page input + , 1 <$ _in_addCategory input + , R.tag (R.current currentPage) (_in_editCategory input) + , R.tag (R.current currentPage) (_in_deleteCategory input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl p = + "api/categories?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs new file mode 100644 index 0000000..fbe76e9 --- /dev/null +++ b/client/src/View/Category/Table.hs @@ -0,0 +1,91 @@ +module View.Category.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, User (..), + UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Category.Form as Form + +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_users :: [User] + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = _in_categories input + , Table._in_cell = cell (_in_users input) (_in_currency input) + , Table._in_cloneModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Clone category + } + , Table._in_editModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Edit category + } + , Table._in_deleteModal = \category -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Category_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/category/", T.pack . show $ _category_id category]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = const True + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | ColorHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Category_Name +headerLabel ColorHeader = Msg.get Msg.Category_Color + +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Category -> m () +cell users currency header category = + case header of + NameHeader -> + R.text $ _category_name category + + ColorHeader -> + Tag.view $ Tag.In + { Tag._in_text = _category_name category + , Tag._in_color = _category_color category + } diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 3f58dd5..5910f52 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -63,6 +63,11 @@ links route = do (R.ffor route (attrs IncomeRoute)) (Msg.get Msg.Income_Title) + Link.view + "/category" + (R.ffor route (attrs CategoryRoute)) + (Msg.get Msg.Category_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index ff6e55e..59f6a0d 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m view input cancel = do rec diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 9e1c5b6..a26e16a 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -21,7 +21,6 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified View.Income.Form as Form -import View.Income.Init (Init (..)) data In t = In { _in_users :: [User] @@ -30,7 +29,7 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income + { _out_add :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index e83ba80..7be8091 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -21,7 +21,6 @@ import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header -import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs deleted file mode 100644 index 4f3ef99..0000000 --- a/client/src/View/Income/Init.hs +++ /dev/null @@ -1,11 +0,0 @@ -module View.Income.Init - ( Init(..) - ) where - -import Common.Model (Income, Payment, User) - -data Init = Init - { _init_users :: [User] - , _init_incomes :: [Income] - , _init_payments :: [Payment] - } deriving (Show) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c623acb..c7f172b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -4,7 +4,6 @@ module View.Income.Table , Out(..) ) where -import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -31,9 +30,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income - , _out_edit :: Event t Income - , _out_delete :: Event t Income + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -41,7 +40,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel - , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input + , Table._in_rows = _in_incomes input , Table._in_cell = cell (_in_users input) (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In @@ -58,7 +57,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) e - return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId } diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 064b5b3..6c31fad 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -51,7 +51,7 @@ data Operation t | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m view input cancel = do rec let reset = R.leftmost diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 0ee0cd3..1915841 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -29,7 +29,7 @@ data In t = In data Out t = Out { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t Payment + , _out_addPayment :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 8d0fee1..26444d7 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -36,7 +36,7 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categories <- AjaxUtil.getNow "api/categories" + categories <- AjaxUtil.getNow "api/allCategories" R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f9215bc..6744d3a 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -21,6 +21,7 @@ import qualified Common.View.Format as Format import qualified Component.ConfirmDialog as ConfirmDialog import qualified Component.Table as Table +import qualified Component.Tag as Tag import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form @@ -35,9 +36,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Payment - , _out_edit :: Event t Payment - , _out_delete :: Event t Payment + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -45,7 +46,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel (_in_frequency input) - , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_rows = _in_payments input , Table._in_cell = cell (_in_users input) @@ -71,7 +72,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) e - return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user } @@ -122,21 +123,12 @@ cell users categories frequency currency header payment = let category = L.find ((== (_payment_category payment)) . _category_id) categories - - attrs = - case category of - Just c -> - M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - - Nothing -> - M.singleton "display" "none" in - R.elAttr "span" attrs $ - R.text $ - Maybe.fromMaybe "" (_category_name <$> category) + Maybe.fromMaybe R.blank . flip fmap category $ \c -> + Tag.view $ Tag.In + { Tag._in_text = _category_name c + , Tag._in_color = _category_color c + } DateHeader -> if frequency == Punctual then diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index a589fc3..0a3b576 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.post "/api/askSignIn") + (Ajax.postAndParseResult "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) diff --git a/common/common.cabal b/common/common.cabal index 17a0ee1..fdede8f 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -31,6 +31,7 @@ Library Exposed-modules: Common.Model + Common.Model.CreateCategoryForm Common.Model.CreateIncomeForm Common.Model.CreatePaymentForm Common.Model.Email @@ -42,6 +43,7 @@ Library Common.Util.Time Common.Util.Validation Common.Validation.Atomic + Common.Validation.Category Common.Validation.Income Common.Validation.Payment Common.Validation.SignIn @@ -52,9 +54,9 @@ Library Common.Message.Lang Common.Message.Translation Common.Model.Category - Common.Model.CreateCategory + Common.Model.CategoryPage Common.Model.Currency - Common.Model.EditCategory + Common.Model.EditCategoryForm Common.Model.EditIncome Common.Model.EditIncomeForm Common.Model.EditPaymentForm diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 00d30f6..73cbf6c 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -1,24 +1,25 @@ module Common.Model (module X) where -import Common.Model.Category as X -import Common.Model.CreateCategory as X -import Common.Model.CreateIncomeForm as X -import Common.Model.CreatePaymentForm as X -import Common.Model.Currency as X -import Common.Model.EditCategory as X -import Common.Model.EditIncome as X -import Common.Model.EditIncomeForm as X -import Common.Model.EditPaymentForm as X -import Common.Model.Email as X -import Common.Model.ExceedingPayer as X -import Common.Model.Frequency as X -import Common.Model.Income as X -import Common.Model.IncomeHeader as X -import Common.Model.IncomePage as X -import Common.Model.Init as X -import Common.Model.InitResult as X -import Common.Model.Payment as X -import Common.Model.PaymentHeader as X -import Common.Model.PaymentPage as X -import Common.Model.SignInForm as X -import Common.Model.User as X +import Common.Model.Category as X +import Common.Model.CategoryPage as X +import Common.Model.CreateCategoryForm as X +import Common.Model.CreateIncomeForm as X +import Common.Model.CreatePaymentForm as X +import Common.Model.Currency as X +import Common.Model.EditCategoryForm as X +import Common.Model.EditIncome as X +import Common.Model.EditIncomeForm as X +import Common.Model.EditPaymentForm as X +import Common.Model.Email as X +import Common.Model.ExceedingPayer as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.IncomeHeader as X +import Common.Model.IncomePage as X +import Common.Model.Init as X +import Common.Model.InitResult as X +import Common.Model.Payment as X +import Common.Model.PaymentHeader as X +import Common.Model.PaymentPage as X +import Common.Model.SignInForm as X +import Common.Model.User as X diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs index db1da53..cc3f795 100644 --- a/common/src/Common/Model/Category.hs +++ b/common/src/Common/Model/Category.hs @@ -18,7 +18,7 @@ data Category = Category , _category_createdAt :: UTCTime , _category_editedAt :: Maybe UTCTime , _category_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON Category instance ToJSON Category diff --git a/common/src/Common/Model/CategoryPage.hs b/common/src/Common/Model/CategoryPage.hs new file mode 100644 index 0000000..476b4ce --- /dev/null +++ b/common/src/Common/Model/CategoryPage.hs @@ -0,0 +1,17 @@ +module Common.Model.CategoryPage + ( CategoryPage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category) + +data CategoryPage = CategoryPage + { _categoryPage_page :: Int + , _categoryPage_categories :: [Category] + , _categoryPage_totalCount :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON CategoryPage +instance ToJSON CategoryPage diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs deleted file mode 100644 index 51bd2a0..0000000 --- a/common/src/Common/Model/CreateCategory.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Common.Model.CreateCategory - ( CreateCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data CreateCategory = CreateCategory - { _createCategory_name :: Text - , _createCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/common/src/Common/Model/CreateCategoryForm.hs b/common/src/Common/Model/CreateCategoryForm.hs new file mode 100644 index 0000000..4668ef4 --- /dev/null +++ b/common/src/Common/Model/CreateCategoryForm.hs @@ -0,0 +1,15 @@ +module Common.Model.CreateCategoryForm + ( CreateCategoryForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateCategoryForm = CreateCategoryForm + { _createCategoryForm_name :: Text + , _createCategoryForm_color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategoryForm +instance ToJSON CreateCategoryForm diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs deleted file mode 100644 index 8b9d9eb..0000000 --- a/common/src/Common/Model/EditCategory.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Common.Model.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text - , _editCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/common/src/Common/Model/EditCategoryForm.hs b/common/src/Common/Model/EditCategoryForm.hs new file mode 100644 index 0000000..a2ceca0 --- /dev/null +++ b/common/src/Common/Model/EditCategoryForm.hs @@ -0,0 +1,18 @@ +module Common.Model.EditCategoryForm + ( EditCategoryForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategoryForm = EditCategoryForm + { _editCategoryForm_id :: CategoryId + , _editCategoryForm_name :: Text + , _editCategoryForm_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategoryForm +instance ToJSON EditCategoryForm diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs index 3516668..2a356df 100644 --- a/common/src/Common/Validation/Atomic.hs +++ b/common/src/Common/Validation/Atomic.hs @@ -4,6 +4,7 @@ module Common.Validation.Atomic , number , nonNullNumber , day + , color ) where import Data.Text (Text) @@ -45,3 +46,7 @@ day str = case Time.parseDay str of Just d -> V.Success d Nothing -> V.Failure $ Msg.get Msg.Form_InvalidDate + +-- TODO: validate +color :: Text -> Validation Text Text +color str = V.Success str diff --git a/common/src/Common/Validation/Category.hs b/common/src/Common/Validation/Category.hs new file mode 100644 index 0000000..f9e6ab4 --- /dev/null +++ b/common/src/Common/Validation/Category.hs @@ -0,0 +1,15 @@ +module Common.Validation.Category + ( name + , color + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import qualified Common.Validation.Atomic as Atomic + +name :: Text -> Validation Text Text +name = Atomic.nonEmpty + +color :: Text -> Validation Text Text +color = Atomic.color diff --git a/server/server.cabal b/server/server.cabal index c9ab2c7..cc6172d 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -94,10 +94,11 @@ Executable server Job.Model Job.MonthlyPayment Job.WeeklyReport - Json LoginSession + Model.CreateCategory Model.CreateIncome Model.CreatePayment + Model.EditCategory Model.EditIncome Model.EditPayment Model.IncomeResource @@ -116,6 +117,7 @@ Executable server Secure SendMail Util.Time + Validation.Category Validation.Income Validation.Payment View.Mail.SignIn diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 8fbc8c8..36ce3fc 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( list + ( listAll + , list , create , edit , delete @@ -7,37 +8,68 @@ module Controller.Category import Control.Monad.IO.Class (liftIO) import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) +import Common.Model (CategoryId, CategoryPage (..), + CreateCategoryForm (..), + EditCategoryForm (..)) import qualified Common.Msg as Msg -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence import qualified Secure +import qualified Validation.Category as CategoryValidation -list :: ActionM () -list = +listAll :: ActionM () +listAll = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.list) >>= json + (liftIO . Query.run $ CategoryPersistence.listAll) >>= json ) -create :: CreateCategory -> ActionM () -create (CreateCategory name color) = +list :: Int -> Int -> ActionM () +list page perPage = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId + (liftIO . Query.run $ do + categories <- CategoryPersistence.list page perPage + count <- CategoryPersistence.count + return $ CategoryPage page categories count + ) >>= json ) -edit :: EditCategory -> ActionM () -edit (EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color - if updated - then status ok200 - else status badRequest400 +create :: CreateCategoryForm -> ActionM () +create form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.createCategory form of + Success (CreateCategory name color) -> do + Right <$> (CategoryPersistence.create name color) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditCategoryForm -> ActionM () +edit form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.editCategory form of + Success (EditCategory categoryId name color) -> + do + isSuccess <- CategoryPersistence.edit categoryId name color + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_CategoryEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest ) delete :: CategoryId -> ActionM () diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs index fd0d2bb..dc9cbc4 100644 --- a/server/src/Controller/Helper.hs +++ b/server/src/Controller/Helper.hs @@ -1,17 +1,16 @@ module Controller.Helper - ( jsonOrBadRequest + ( okOrBadRequest ) where -import Data.Aeson (ToJSON) import Data.Text (Text) import qualified Data.Text.Lazy as LT import qualified Network.HTTP.Types.Status as Status import Web.Scotty (ActionM) import qualified Web.Scotty as S -jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () -jsonOrBadRequest (Left message) = do +okOrBadRequest :: Either Text () -> ActionM () +okOrBadRequest (Left message) = do S.status Status.badRequest400 S.text (LT.fromStrict message) -jsonOrBadRequest (Right a) = - S.json a +okOrBadRequest (Right ()) = + S.status Status.ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 784a2db..96ccbbc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -8,7 +8,7 @@ module Controller.Income import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) @@ -16,6 +16,7 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) +import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -60,7 +61,7 @@ create form = Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditIncomeForm -> ActionM () @@ -68,12 +69,17 @@ edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do case IncomeValidation.editIncome form of - Success (EditIncome incomeId amount date) -> do - Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + Success (EditIncome incomeId amount date) -> + do + isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_IncomeEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: IncomeId -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 42a4436..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -8,7 +8,6 @@ module Controller.Payment import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M -import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar import Data.Validation (Validation (Failure, Success)) @@ -77,30 +76,30 @@ create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.createPayment cs form of Success (CreatePayment name cost date category frequency) -> Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditPaymentForm -> ActionM () edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency - if Maybe.isJust editedPayment then - return . Right $ editedPayment + isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + return $ if isSuccess then + Right () else - return . Left $ Msg.get Msg.Error_PaymentEdit + Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: PaymentId -> ActionM () diff --git a/server/src/Json.hs b/server/src/Json.hs deleted file mode 100644 index 6d40305..0000000 --- a/server/src/Json.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Json - ( jsonObject - , jsonId - ) where - -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Data.Int (Int64) -import Data.Text (Text) -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/server/src/Main.hs b/server/src/Main.hs index f4d75a0..0b80de0 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -77,8 +77,13 @@ main = do incomeId <- S.param "id" Income.delete incomeId - S.get "/api/categories" $ - Category.list + S.get "/api/allCategories" $ do + Category.listAll + + S.get "/api/categories" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Category.list page perPage S.post "/api/category" $ S.jsonData >>= Category.create diff --git a/server/src/Model/CreateCategory.hs b/server/src/Model/CreateCategory.hs new file mode 100644 index 0000000..dae061b --- /dev/null +++ b/server/src/Model/CreateCategory.hs @@ -0,0 +1,10 @@ +module Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Text (Text) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/EditCategory.hs b/server/src/Model/EditCategory.hs new file mode 100644 index 0000000..8ee26ac --- /dev/null +++ b/server/src/Model/EditCategory.hs @@ -0,0 +1,13 @@ +module Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Text (Text) + +import Common.Model (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show) diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 00cf0a5..2934b28 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -1,5 +1,7 @@ module Persistence.Category - ( list + ( count + , list + , listAll , create , edit , delete @@ -27,14 +29,37 @@ instance FromRow Row where SQLite.field <*> SQLite.field) -list :: Query [Category] -list = +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM category WHERE deleted_at IS NULL" + ) + + +list :: Int -> Int -> Query [Category] +list page perPage = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query + conn + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + +listAll :: Query [Category] +listAll = Query (\conn -> map (\(Row c) -> c) <$> SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" ) -create :: Text -> Text -> Query CategoryId +create :: Text -> Text -> Query () create categoryName categoryColor = Query (\conn -> do now <- getCurrentTime @@ -42,7 +67,6 @@ create categoryName categoryColor = conn "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn ) edit :: CategoryId -> Text -> Text -> Query Bool diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index e689505..cd98814 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -78,7 +78,7 @@ listModifiedSince since = (since, since, since) ) -create :: UserId -> Day -> Int -> Query Income +create :: UserId -> Day -> Int -> Query () create userId date amount = Query (\conn -> do createdAt <- getCurrentTime @@ -86,42 +86,23 @@ create userId date amount = conn "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" (userId, date, amount, createdAt) - incomeId <- SQLite.lastInsertRowId conn - return $ Income - { _income_id = incomeId - , _income_userId = userId - , _income_date = date - , _income_amount = amount - , _income_createdAt = createdAt - , _income_editedAt = Nothing - , _income_deletedAt = Nothing - } ) -edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool edit userId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> + income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - do - currentTime <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" - (currentTime, incomeDate, incomeAmount, incomeId, userId) - return . Just $ Income - { _income_id = incomeId - , _income_userId = userId - , _income_date = incomeDate - , _income_amount = incomeAmount - , _income_createdAt = _income_createdAt income - , _income_editedAt = Just currentTime - , _income_deletedAt = Nothing - } - Nothing -> - return Nothing + if Maybe.isJust income then + do + currentTime <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" + (currentTime, incomeDate, incomeAmount, incomeId, userId) + return True + else + return False ) delete :: UserId -> PaymentId -> Query () diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 953f0ae..da877ff 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -190,30 +190,17 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () create userId name cost date category frequency = Query (\conn -> do - time <- getCurrentTime + currentTime <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) - (userId, name, cost, date, category, FrequencyField frequency, time) - paymentId <- SQLite.lastInsertRowId conn - return $ Payment - { _payment_id = paymentId - , _payment_user = userId - , _payment_name = name - , _payment_cost = cost - , _payment_date = date - , _payment_category = category - , _payment_frequency = frequency - , _payment_createdAt = time - , _payment_editedAt = Nothing - , _payment_deletedAt = Nothing - } + (userId, name, cost, date, category, FrequencyField frequency, currentTime) ) createMany :: [Payment] -> Query () @@ -228,17 +215,17 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment) +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Bool edit userId paymentId name cost date category frequency = Query (\conn -> do - mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> SQLite.query conn (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") (paymentId, userId) - case mbPayment of - Just payment -> do - now <- getCurrentTime + if Maybe.isJust payment then + do + currentTime <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " @@ -255,7 +242,7 @@ edit userId paymentId name cost date category frequency = , " id = ?" , " AND user_id = ?" ]) - ( now + ( currentTime , name , cost , date @@ -264,20 +251,9 @@ edit userId paymentId name cost date category frequency = , paymentId , userId ) - return . Just $ Payment - { _payment_id = paymentId - , _payment_user = userId - , _payment_name = name - , _payment_cost = cost - , _payment_date = date - , _payment_category = category - , _payment_frequency = frequency - , _payment_createdAt = _payment_createdAt payment - , _payment_editedAt = Just now - , _payment_deletedAt = Nothing - } - Nothing -> - return Nothing + return True + else + return False ) delete :: UserId -> PaymentId -> Query () diff --git a/server/src/Validation/Category.hs b/server/src/Validation/Category.hs new file mode 100644 index 0000000..12f2117 --- /dev/null +++ b/server/src/Validation/Category.hs @@ -0,0 +1,27 @@ +module Validation.Category + ( createCategory + , editCategory + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Validation.Category as CategoryValidation +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) + +createCategory :: CreateCategoryForm -> Validation Text CreateCategory +createCategory form = + CreateCategory + <$> CategoryValidation.name (_createCategoryForm_name form) + <*> CategoryValidation.color (_createCategoryForm_color form) + +editCategory :: EditCategoryForm -> Validation Text EditCategory +editCategory form = + EditCategory + <$> V.Success (_editCategoryForm_id form) + <*> CategoryValidation.name (_editCategoryForm_name form) + <*> CategoryValidation.color (_editCategoryForm_color form) |