diff options
51 files changed, 799 insertions, 419 deletions
diff --git a/.tmuxinator.yml b/.tmuxinator.yml index 48b5add..1576496 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -1,11 +1,13 @@ name: sharedCost windows: - - main: - layout: 3747,239x59,0,0{144x59,0,0,0,94x59,145,0[94x30,145,0,1,94x28,145,31,2]} + - console: + - clear + - app: panes: - - # Empty - - make clean-client watch-client - - make clean-server watch-server + - client: + - make clean-client watch-client + - server: + - make clean-server watch-server - db: - sqlite3 database @@ -75,7 +75,7 @@ TODO ### Code -- R.def for custom components. +- modal as body child https://stackoverflow.com/questions/33711392/what-is-the-proper-way-in-reflex-dom-to-handle-a-modal-dialog - Move up element ids security (editOwn is actually at db level). - move persistence methods to a module. - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) diff --git a/client/client.cabal b/client/client.cabal index 1064e7d..0aec05f 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -33,13 +33,20 @@ Executable client other-modules: Component.Button + Component.Form Component.Input Component.Modal + Component.Select Icon + Util.Ajax + Util.Dom Util.List + Util.WaitFor View.App View.Header View.Payment + View.Payment.Add + View.Payment.Delete View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component.hs b/client/src/Component.hs index dea384e..7b87a75 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -1,5 +1,7 @@ module Component (module X) where import Component.Button as X +import Component.Form as X import Component.Input as X import Component.Modal as X +import Component.Select as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 3ee9561..bf604f1 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -2,10 +2,11 @@ module Component.Button ( ButtonIn(..) , ButtonOut(..) , button - , buttonInDefault + , defaultButtonIn ) where import qualified Data.Map as M +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -14,22 +15,36 @@ import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Dynamic t Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool + { _buttonIn_class :: Dynamic t Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + , _buttonIn_tabIndex :: Maybe Int + , _buttonIn_submit :: Bool } -buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m -buttonInDefault = ButtonIn - { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.blank - , _buttonIn_waiting = R.never +defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m +defaultButtonIn content = ButtonIn + { _buttonIn_class = R.constDyn "" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False } +-- defaultButtonIn :: MonadWidget t m => ButtonIn t m +-- defaultButtonIn = ButtonIn +-- { _buttonIn_class = R.constDyn "" +-- , _buttonIn_content = R.blank +-- , _buttonIn_waiting = R.never +-- , _buttonIn_tabIndex = Nothing +-- , _buttonIn_submit = False +-- } + data ButtonOut t = ButtonOut { _buttonOut_clic :: Event t () } + button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn @@ -37,9 +52,11 @@ button buttonIn = do let attr = do buttonClass <- _buttonIn_class buttonIn waiting <- dynWaiting - return $ if waiting - then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])] - else M.fromList [("type", "button"), ("class", buttonClass)] + return . M.fromList . catMaybes $ + [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button") + , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn + , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ]) + ] (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs new file mode 100644 index 0000000..0a89c6e --- /dev/null +++ b/client/src/Component/Form.hs @@ -0,0 +1,12 @@ +module Component.Form + ( form + ) where + +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 content = + R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ + content diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 24aac22..92f8ec9 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -2,12 +2,14 @@ module Component.Input ( InputIn(..) , InputOut(..) , input + , defaultInputIn ) where import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~)) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&), + (.~)) import qualified Reflex.Dom as R import Component.Button (ButtonIn (..), ButtonOut (..)) @@ -15,8 +17,16 @@ import qualified Component.Button as Button import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_label :: Text + { _inputIn_reset :: Event t a + , _inputIn_label :: Text + , _inputIn_initialValue :: Text + } + +defaultInputIn :: (Reflex t) => InputIn t a b +defaultInputIn = InputIn + { _inputIn_reset = R.never + , _inputIn_label = "" + , _inputIn_initialValue = "" } data InputOut t = InputOut @@ -41,14 +51,15 @@ input inputIn = textInput <- R.textInput $ R.def & R.attributes .~ attributes & R.setValue .~ resetValue + & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) R.el "label" $ R.text (_inputIn_label inputIn) - reset <- Button.button $ ButtonIn - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_content = Icon.cross - , _buttonIn_waiting = R.never - } + reset <- Button.button $ + (Button.defaultButtonIn Icon.cross) + { _buttonIn_class = R.constDyn "reset" + , _buttonIn_tabIndex = Just (-1) + } let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index bfb5e02..1d70c90 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -10,18 +10,22 @@ import qualified Data.Map as M import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R -data ModalIn t m = ModalIn +data ModalIn t m a = ModalIn { _modalIn_show :: Event t () - , _modalIn_content :: m () + , _modalIn_hide :: Event t () + , _modalIn_content :: m a } -data ModalOut = ModalOut {} +data ModalOut a = ModalOut + { _modalOut_content :: a + } -modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut +modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) modal modalIn = do rec showModal <- R.holdDyn False $ R.leftmost [ True <$ _modalIn_show modalIn + , False <$ _modalIn_hide modalIn , False <$ curtainClick ] @@ -30,9 +34,11 @@ modal modalIn = do , ("class", "modal") ]) - curtainClick <- R.elDynAttr "div" attr $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank - R.divClass "content" $ _modalIn_content modalIn - return $ R.domEvent R.Click curtain + (curtainClick, content) <- R.elDynAttr "div" attr $ 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) - return $ ModalOut {} + return $ ModalOut + { _modalOut_content = content + } diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs new file mode 100644 index 0000000..876548e --- /dev/null +++ b/client/src/Component/Select.hs @@ -0,0 +1,32 @@ +module Component.Select + ( SelectIn(..) + , SelectOut(..) + , select + ) where + +import Data.Map (Map) +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +data (Reflex t) => SelectIn t a = SelectIn + { _selectIn_label :: Text + , _selectIn_initialValue :: a + , _selectIn_values :: Dynamic t (Map a Text) + } + +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 selectIn = + R.divClass "selectInput" $ do + R.el "label" $ R.text (_selectIn_label selectIn) + + value <- R._dropdown_value <$> + R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def + + return SelectOut + { _selectOut_value = value + } diff --git a/client/src/Main.hs b/client/src/Main.hs index d55eefe..6c048c6 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -13,7 +13,7 @@ import JSDOM.Types (HTMLElement (..), JSM) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import Common.Model (InitResult (InitEmpty)) +import Common.Model (InitResult (InitError)) import qualified Common.Msg as Msg import qualified View.App as App @@ -37,4 +37,4 @@ readInit = do _ -> return initParseError - where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError) + where initParseError = InitError $ Msg.get Msg.SignIn_ParseError diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs new file mode 100644 index 0000000..1e8e4c7 --- /dev/null +++ b/client/src/Util/Ajax.hs @@ -0,0 +1,20 @@ +module Util.Ajax + ( post + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +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" diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs new file mode 100644 index 0000000..0175c95 --- /dev/null +++ b/client/src/Util/WaitFor.hs @@ -0,0 +1,18 @@ +module Util.WaitFor + ( waitFor + ) where + +import Data.Time (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +waitFor + :: forall t m a b. MonadWidget t m + => (Event t a -> m (Event t b)) + -> Event t () + -> Dynamic t a + -> m (Event t b, Event t Bool) +waitFor op start input = do + result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime) + let waiting = R.leftmost [ const True <$> start , const False <$> result ] + return (result, waiting) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 64ca303..9aa6c57 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -29,10 +29,12 @@ widget initResult = { _paymentIn_init = initSuccess } return () - InitEmpty result -> - SignIn.view result + InitEmpty -> + SignIn.view SignIn.EmptyMessage + InitError error -> + SignIn.view (SignIn.ErrorMessage error) - signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess) + signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 4c74383..8f1fb78 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -13,9 +13,8 @@ import qualified Reflex.Dom as R import Common.Model (Init (..), InitResult (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg - +import qualified Component as Component import Component.Button (ButtonIn (..)) -import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec - signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = R.constDyn "signOut item" - , Component._buttonIn_content = Icon.signOut - , Component._buttonIn_waiting = waiting - } + signOut <- Component.button $ + (Component.defaultButtonIn Icon.signOut) + { _buttonIn_class = R.constDyn "signOut item" + , _buttonIn_waiting = waiting + } let signOutClic = Component._buttonOut_clic signOut waiting = R.leftmost [ fmap (const True) signOutClic diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs new file mode 100644 index 0000000..2eaec0f --- /dev/null +++ b/client/src/View/Payment/Add.hs @@ -0,0 +1,104 @@ +module View.Payment.Add + ( view + , AddIn(..) + , AddOut(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.View.Format as Format +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +data AddIn = AddIn + { _addIn_categories :: [Category] + } + +data AddOut t = AddOut + { _addOut_cancel :: Event t () + } + +view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view addIn = do + R.divClass "add" $ do + R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add + + R.divClass "addContent" $ do + name <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + + cost <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + + currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + + date <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = Format.shortDay currentDay + }) + + frequency <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Frequency + , _selectIn_initialValue = Punctual + , _selectIn_values = R.constDyn frequencies + }) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = 0 + , _selectIn_values = R.constDyn categories + }) + + let payment = CreatePayment + <$> name + <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost + <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date + <*> category + <*> frequency + + cancel <- R.divClass "buttons" $ do + rec + validate <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (_, waiting) <- Util.waitFor + (Ajax.post "/payment") + validate + payment + + Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return AddOut + { _addOut_cancel = cancel + } + + where + frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> + (_category_id c, _category_name c) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs new file mode 100644 index 0000000..a1be16d --- /dev/null +++ b/client/src/View/Payment/Delete.hs @@ -0,0 +1,51 @@ +module View.Payment.Delete + ( view + , DeleteIn(..) + , 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 + {} + +data DeleteOut t = DeleteOut + { _deleteOut_cancel :: Event t () + } + +view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t) +view _ = + R.divClass "delete" $ do + R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm + + R.divClass "deleteContent" $ do + + cancel <- R.divClass "buttons" $ do + rec + _ <- 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") + -- validate + -- payment + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return cancel + + return DeleteOut + { _deleteOut_cancel = cancel + } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index a694136..d01dec6 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -16,9 +16,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Currency, ExceedingPayer (..), - Frequency (..), Income (..), Init (..), - Payment (..), User (..)) +import Common.Model (Category, Currency, + ExceedingPayer (..), Frequency (..), + Income (..), Init (..), Payment (..), + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -26,9 +27,11 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..)) + ModalIn (..), ModalOut (..)) import qualified Component as Component import qualified Util.List as L +import View.Payment.Add (AddIn (..), AddOut (..)) +import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn { _headerIn_init :: Init @@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users currency + payerAndAdd incomes punctualPayments users categories currency (searchName, searchFrequency) <- searchLine let searchPayments = getSearchPayments searchName searchFrequency payments infos searchPayments users currency @@ -56,6 +59,7 @@ widget headerIn = payments = _init_payments init punctualPayments = filter ((==) Punctual . _payment_frequency) payments users = _init_users init + categories = _init_categories init currency = _init_currency init getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] @@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do n <- name f <- frequency pure $ flip filter payments (\p -> - ( T.search n (_payment_name p) + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) && (_payment_frequency p == f) )) -payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () -payerAndAdd incomes payments users currency = do +payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m () +payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do R.divClass "exceedingPayers" $ @@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False }) - _ <- Component.modal $ ModalIn - { _modalIn_show = addPayment - , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement" - } + rec + modalOut <- Component.modal $ ModalIn + { _modalIn_show = addPayment + , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut + , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + } return () searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) @@ -99,6 +107,7 @@ searchLine = do searchName <- _inputOut_value <$> (Component.input $ InputIn { _inputIn_reset = R.never , _inputIn_label = Msg.get Msg.Search_Name + , _inputIn_initialValue = "" }) let frequencies = M.fromList diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 55ceb9f..d14b640 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -82,5 +82,7 @@ pageButton currentPage page content = do if cp == Just p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index a49be5c..23d7225 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,23 +4,28 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format +import Component (ButtonIn (..), ButtonOut (..), + ModalIn (..), ModalOut (..)) +import qualified Component as Component +import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) +import qualified View.Payment.Delete as Delete import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Dom as Dom data TableIn t = TableIn { _tableIn_init :: Init @@ -105,8 +110,17 @@ paymentRow init payment = M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] R.elDynAttr "div" modifyAttrs $ R.el "button" $ Icon.edit - R.elDynAttr "div" modifyAttrs $ - R.el "button" $ Icon.delete + deletePayment <- R.elDynAttr "div" modifyAttrs $ + _buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn Icon.delete) + { _buttonIn_class = R.constDyn "deletePayment" }) + rec + modalOut <- Component.modal $ ModalIn + { _modalIn_show = deletePayment + , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_content = Delete.view (DeleteIn {}) + } + return () findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 89be737..912aea2 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,11 +1,10 @@ module View.SignIn - ( view + ( SignInMessage (..) + , view ) where import qualified Data.Either as Either -import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time (NominalDiffTime) import Prelude hiding (error) import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -16,62 +15,47 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component - -view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () -view result = - R.divClass "signIn" $ do - rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_label = Msg.get Msg.SignIn_EmailLabel - } - - let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button - - dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ - [ fmap (const True) userWantsEmailValidation - , fmap (const False) signInResult - ] - - uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail - - let validatedEmail = R.tagPromptlyDyn - (_inputOut_value input) - (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) - - let waiting = R.leftmost - [ fmap (const True) validatedEmail - , fmap (const False) signInResult - ] - - button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "validate" - , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) - , _buttonIn_waiting = waiting - } - - signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) - - showSignInResult result signInResult - -askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) -askSignIn email = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email - getResult response = - case R._xhrResponse_responseText response of - Just key -> - if R._xhrResponse_status response == 200 then Right key else Left key - _ -> Left "NoKey" - -showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () -showSignInResult result signInResult = do - _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +data SignInMessage = + SuccessMessage Text + | ErrorMessage Text + | EmptyMessage + +view :: forall t m. MonadWidget t m => SignInMessage -> m () +view signInMessage = + R.divClass "signIn" $ + Component.form $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_initialValue = "" + } + + button <- Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) + { _buttonIn_class = R.constDyn "validate" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + } + + (signInResult, waiting) <- Util.waitFor + (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (_buttonOut_clic button) + (_inputOut_value input) + + showSignInResult signInMessage signInResult + +showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m () +showSignInResult signInMessage signInResult = do + _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + where showInitResult (SuccessMessage success) = showSuccess success + showInitResult (ErrorMessage error) = showError error + showInitResult EmptyMessage = R.blank showResult (Left error) = showError error showResult (Right success) = showSuccess success diff --git a/common/common.cabal b/common/common.cabal index 7eadb49..6e5c8fb 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,6 +29,7 @@ Library Common.Model Common.Msg Common.Util.Text + Common.Util.Time Common.View.Format other-modules: diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index 8e2ab73..cd0b01d 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -2,7 +2,7 @@ module Common.Model.CreatePayment ( CreatePayment(..) ) where -import Data.Aeson (FromJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import Data.Time.Calendar (Day) import GHC.Generics (Generic) @@ -19,3 +19,4 @@ data CreatePayment = CreatePayment } deriving (Show, Generic) instance FromJSON CreatePayment +instance ToJSON CreatePayment diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs index 542e6c7..f4c08a9 100644 --- a/common/src/Common/Model/InitResult.hs +++ b/common/src/Common/Model/InitResult.hs @@ -10,7 +10,8 @@ import Common.Model.Init (Init) data InitResult = InitSuccess Init - | InitEmpty (Either Text (Maybe Text)) + | InitError Text + | InitEmpty deriving (Show, Generic) instance FromJSON InitResult diff --git a/common/src/Common/Util/Time.hs b/common/src/Common/Util/Time.hs new file mode 100644 index 0000000..9ab7ab5 --- /dev/null +++ b/common/src/Common/Util/Time.hs @@ -0,0 +1,26 @@ +module Common.Util.Time + ( timeToDay + , parseDay + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import qualified Data.Time as Time +import Data.Time.Calendar (Day) +import Data.Time.LocalTime +import qualified Text.Read as T + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time + +parseDay :: Text -> Maybe Day +parseDay str = do + (d, m, y) <- + case T.splitOn str "/" of + [d, m, y] -> Just (d, m, y) + _ -> Nothing + d' <- T.readMaybe . T.unpack $ d + m' <- T.readMaybe . T.unpack $ m + y' <- T.readMaybe . T.unpack $ y + return $ Time.fromGregorian y' m' d' diff --git a/server/server.cabal b/server/server.cabal index ada7040..2bfd18d 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -72,6 +72,7 @@ Executable server Design.Tooltip Design.View.Header Design.View.Payment + Design.View.Payment.Add Design.View.Payment.Header Design.View.Payment.Pages Design.View.Payment.Table @@ -87,17 +88,17 @@ Executable server Job.WeeklyReport Json LoginSession - Model.Category - Model.Frequency - Model.Income - Model.Init Model.Mail - Model.Payment - Model.PaymentCategory Model.Query Model.SignIn Model.UUID - Model.User + Persistence.Category + Persistence.Frequency + Persistence.Income + Persistence.Init + Persistence.Payment + Persistence.PaymentCategory + Persistence.User Resource Secure SendMail diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 5565b43..37b8357 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -4,31 +4,31 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty hiding (delete) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) -import qualified Common.Msg as Msg +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) +import qualified Common.Msg as Msg -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure create :: CreateCategory -> ActionM () create (CreateCategory name color) = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Category.create name color) >>= jsonId + (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId ) edit :: EditCategory -> ActionM () edit (EditCategory categoryId name color) = Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color + updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color if updated then status ok200 else status badRequest400 @@ -38,9 +38,9 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId + paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId if null paymentCategories - then Category.delete categoryId + then CategoryPersistence.delete categoryId else return False if deleted then diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 19f0cfc..3f623e5 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -14,20 +14,20 @@ import Common.Model (CreateIncome (..), EditIncome (..), import qualified Common.Msg as Msg import Json (jsonId) -import qualified Model.Income as Income import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence import qualified Secure create :: CreateIncome -> ActionM () create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId + (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId ) editOwn :: EditIncome -> ActionM () editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount + updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -36,7 +36,7 @@ editOwn (EditIncome incomeId date amount) = deleteOwn :: IncomeId -> ActionM () deleteOwn incomeId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId + deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId if deleted then status ok200 diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 9a3e2b7..f942540 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -23,11 +23,11 @@ import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession -import Model.Init (getInit) import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) +import qualified Persistence.Init as InitPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn @@ -39,16 +39,16 @@ get conf = do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return . InitEmpty . Right $ Nothing + return InitEmpty Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf + liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf S.html $ page initResult askSignIn :: Conf -> SignIn -> ActionM () askSignIn conf (SignIn email) = if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.get email + maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do token <- liftIO . Query.run $ SignIn.createSignInToken email @@ -71,7 +71,7 @@ trySignIn conf token = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + S.html $ page (InitError $ Msg.get errorKey) Right _ -> S.redirect "/" @@ -100,7 +100,7 @@ validateSignIn conf textToken = do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn + UserPersistence.get . SignIn.email $ signIn return $ case mbUser of Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user @@ -112,7 +112,7 @@ getLoggedUser = do Nothing -> return Nothing Just token -> do - liftIO . Query.run . getUserFromToken $ token + liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index f2af6c9..e1936f0 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -5,54 +5,54 @@ module Controller.Payment , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (badRequest400, ok200) +import Control.Monad.IO.Class (liftIO) +import qualified Network.HTTP.Types.Status as Status import Web.Scotty -import Common.Model (CreatePayment (..), - EditPayment (..), PaymentId, - User (..)) +import Common.Model (CreatePayment (..), + EditPayment (..), PaymentId, + User (..)) -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import qualified Json +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.listActive) >>= json + (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) create :: CreatePayment -> ActionM () create (CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId + PaymentCategoryPersistence.save name category + PaymentPersistence.create (_user_id user) name cost date frequency + ) >>= Json.jsonId ) editOwn :: EditPayment -> ActionM () editOwn (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency + edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited - then PaymentCategory.save name category >> return () + then PaymentCategoryPersistence.save name category >> return () else return () return edited if updated - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId + deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId if deleted - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index be0e74f..0385cb4 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -53,8 +53,10 @@ design = do right (px 0) top (px 27) zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" + svg ? "path" ? + ("fill" -: Color.toString Color.silver) + hover & svg ? "path" ? + ("fill" -: Color.toString (Color.silver -. 25)) (input # ".filled" |+ label) <> (input # focus |+ label) ? do top (px 0) @@ -108,18 +110,18 @@ design = do fontWeight bold ".selectInput" ? do + marginBottom (em 1) label ? do display block marginBottom (px 10) fontSize (pct 80) select ? do + width (pct 100) backgroundColor Color.white border solid (px 1) Color.silver sym borderRadius (px 3) sym2 padding (px 5) (px 8) - option ? do - firstChild & display none - sym2 padding (px 5) (px 8) + option ? sym2 padding (px 5) (px 8) ".error" & do select ? borderColor Color.chestnutRose ".errorMessage" ? do diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 2612257..ce427c0 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -9,19 +9,18 @@ import Clay design :: Css design = do - ".curtain" ? do + ".modalCurtain" ? do position fixed - cursor pointer top (px 0) left (px 0) width (pct 100) height (pct 100) - backgroundColor (rgba 0 0 0 0.5) + backgroundColor (rgba 0 0 0 0.7) zIndex 1000 opacity 1 transition "all" (sec 0.2) ease (sec 0) - ".content" ? do + ".modalContent" ? do minWidth (px 270) position fixed top (pct 25) @@ -29,7 +28,6 @@ design = do "transform" -: "translate(-50%, -25%)" zIndex 1000 backgroundColor white - sym padding (px 20) sym borderRadius (px 5) boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 0d59fa0..2102ff8 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,6 +4,7 @@ module Design.View.Payment import Clay +import qualified Design.View.Payment.Add as Add import qualified Design.View.Payment.Header as Header import qualified Design.View.Payment.Pages as Pages import qualified Design.View.Payment.Table as Table @@ -11,5 +12,6 @@ import qualified Design.View.Payment.Table as Table design :: Css design = do ".header" ? Header.design + ".add" ? Add.design ".table" ? Table.design ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs new file mode 100644 index 0000000..199ad36 --- /dev/null +++ b/server/src/Design/View/Payment/Add.hs @@ -0,0 +1,32 @@ +module Design.View.Payment.Add + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".addHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".addContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 80c5436..0cb5b5d 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -6,8 +6,6 @@ import Data.Monoid ((<>)) import Clay -import Design.Constants - import qualified Design.Color as Color import qualified Design.Constants as Constants import qualified Design.Helper as Helper @@ -17,8 +15,8 @@ design :: Css design = do Media.desktop $ marginBottom (em 3) Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) ".payerAndAdd" ? do Media.tabletDesktop $ display flex @@ -55,9 +53,6 @@ design = do ".textInput" ? do display inlineBlock marginBottom (px 0) - button ? do - svg ? "path" ? ("fill" -: Color.toString Color.silver) - hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25)) Media.tabletDesktop $ marginRight (px 30) Media.mobile $ do diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 907be2b..dfbe8b4 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,19 +2,19 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Common.Model (Frequency (..), Payment (..)) +import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Util.Time as Time -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import Util.Time (timeToDay) +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName + monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName now <- getCurrentTime - actualDay <- timeToDay now + actualDay <- Time.timeToDay now let punctualPayments = map (\p -> p { _payment_frequency = Punctual @@ -22,5 +22,5 @@ monthlyPayment _ = do , _payment_createdAt = now }) monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) + _ <- Query.run (PaymentPersistence.createMany punctualPayments) return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 38d88b5..203c4e8 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -5,10 +5,10 @@ module Job.WeeklyReport import Data.Time.Clock (UTCTime, getCurrentTime) import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment import qualified Model.Query as Query -import qualified Model.User as User +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified SendMail import qualified View.Mail.WeeklyReport as WeeklyReport @@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> Payment.listPunctual <*> Income.list <*> User.list + (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now diff --git a/server/src/Model/IncomeResource.hs b/server/src/Model/IncomeResource.hs new file mode 100644 index 0000000..6ab5f18 --- /dev/null +++ b/server/src/Model/IncomeResource.hs @@ -0,0 +1,15 @@ +module Model.IncomeResource + ( IncomeResource(..) + ) where + +import Common.Model (Income (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype IncomeResource = IncomeResource Income + +instance Resource IncomeResource where + resourceCreatedAt (IncomeResource i) = _income_createdAt i + resourceEditedAt (IncomeResource i) = _income_editedAt i + resourceDeletedAt (IncomeResource i) = _income_deletedAt i diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs deleted file mode 100644 index 0a0ffc7..0000000 --- a/server/src/Model/Init.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Model.Init - ( getInit - ) where - -import Common.Model (Init (Init), User (..)) - -import Conf (Conf) -import qualified Conf -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import Model.Query (Query) -import qualified Model.User as User - -getInit :: User -> Conf -> Query Init -getInit user conf = - Init <$> - User.list <*> - (return . _user_id $ user) <*> - Payment.listActive <*> - Income.list <*> - Category.list <*> - PaymentCategory.list <*> - (return . Conf.currency $ conf) diff --git a/server/src/Model/PaymentResource.hs b/server/src/Model/PaymentResource.hs new file mode 100644 index 0000000..1ea978c --- /dev/null +++ b/server/src/Model/PaymentResource.hs @@ -0,0 +1,15 @@ +module Model.PaymentResource + ( PaymentResource(..) + ) where + +import Common.Model (Payment (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype PaymentResource = PaymentResource Payment + +instance Resource PaymentResource where + resourceCreatedAt (PaymentResource p) = _payment_createdAt p + resourceEditedAt (PaymentResource p) = _payment_editedAt p + resourceDeletedAt (PaymentResource p) = _payment_deletedAt p diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs deleted file mode 100644 index 8dc1fc8..0000000 --- a/server/src/Model/User.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.User - ( list - , get - , create - , delete - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (User (..), UserId) - -import Model.Query (Query (Query)) - -instance FromRow User where - fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field - -list :: Query [User] -list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") - -get :: Text -> Query (Maybe User) -get userEmail = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) - ) - -create :: Text -> Text -> Query UserId -create userEmail userName = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" - (now, userEmail, userName) - SQLite.lastInsertRowId conn - ) - -delete :: Text -> Query () -delete userEmail = - Query (\conn -> - SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) - ) diff --git a/server/src/Model/Category.hs b/server/src/Persistence/Category.hs index ee406bc..2afe5db 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Persistence/Category.hs @@ -1,6 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category +module Persistence.Category ( list , create , edit @@ -18,19 +16,22 @@ import Common.Model (Category (..), CategoryId) import Model.Query (Query (Query)) -instance FromRow Category where - fromRow = Category <$> +newtype Row = Row Category + +instance FromRow Row where + fromRow = Row <$> (Category <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> - SQLite.field + SQLite.field) list :: Query [Category] list = Query (\conn -> - SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + map (\(Row c) -> c) <$> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" ) create :: Text -> Text -> Query CategoryId @@ -47,8 +48,8 @@ create categoryName categoryColor = edit :: CategoryId -> Text -> Text -> Query Bool edit categoryId categoryName categoryColor = Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) if isJust mbCategory then do now <- getCurrentTime @@ -64,8 +65,8 @@ edit categoryId categoryName categoryColor = delete :: CategoryId -> Query Bool delete categoryId = Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) if isJust mbCategory then do now <- getCurrentTime diff --git a/server/src/Model/Frequency.hs b/server/src/Persistence/Frequency.hs index c29cf37..edaa844 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Persistence/Frequency.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where +module Persistence.Frequency + ( FrequencyField(..) + ) where import qualified Data.Text as T import Database.SQLite.Simple (SQLData (SQLText)) @@ -11,10 +11,13 @@ import Database.SQLite.Simple.ToField (ToField (toField)) import Common.Model (Frequency) -instance FromField Frequency where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Frequency) - _ -> Errors [error "SQLText field required for frequency"] +newtype FrequencyField = FrequencyField Frequency + +instance FromField FrequencyField where + fromField field = + case fieldData field of + SQLText text -> Ok (FrequencyField (read (T.unpack text) :: Frequency)) + _ -> Errors [error "SQLText field required for frequency"] -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency +instance ToField FrequencyField where + toField (FrequencyField f) = SQLText . T.pack . show $ f diff --git a/server/src/Model/Income.hs b/server/src/Persistence/Income.hs index 4938e50..a863f85 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,6 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income +module Persistence.Income ( list , create , editOwn @@ -18,26 +16,25 @@ import Common.Model (Income (..), IncomeId, User (..), UserId) import Model.Query (Query (Query)) -import Resource (Resource, resourceCreatedAt, - resourceDeletedAt, resourceEditedAt) -instance Resource Income where - resourceCreatedAt = _income_createdAt - resourceEditedAt = _income_editedAt - resourceDeletedAt = _income_deletedAt +newtype Row = Row Income -instance FromRow Income where - fromRow = Income <$> +instance FromRow Row where + fromRow = Row <$> (Income <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> - SQLite.field + SQLite.field) list :: Query [Income] -list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") +list = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" + ) create :: UserId -> Day -> Int -> Query IncomeId create incomeUserId incomeDate incomeAmount = @@ -53,7 +50,8 @@ create incomeUserId incomeDate incomeAmount = editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool editOwn incomeUserId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> + SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> if _income_userId income == incomeUserId @@ -73,7 +71,9 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = deleteOwn :: User -> IncomeId -> Query Bool deleteOwn user incomeId = Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + mbIncome <- + fmap (\(Row i) -> i) . listToMaybe <$> + SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> if _income_userId income == _user_id user diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs new file mode 100644 index 0000000..74d9172 --- /dev/null +++ b/server/src/Persistence/Init.hs @@ -0,0 +1,25 @@ +module Persistence.Init + ( getInit + ) where + +import Common.Model (Init (Init), User (..)) + +import Conf (Conf) +import qualified Conf +import Model.Query (Query) +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import qualified Persistence.User as UserPersistence + +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + UserPersistence.list <*> + (return . _user_id $ user) <*> + PaymentPersistence.listActive <*> + IncomePersistence.list <*> + CategoryPersistence.list <*> + PaymentCategoryPersistence.list <*> + (return . Conf.currency $ conf) diff --git a/server/src/Model/Payment.hs b/server/src/Persistence/Payment.hs index 5b29409..32600d7 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,6 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment +module Persistence.Payment ( Payment(..) , find , listActive @@ -26,71 +24,73 @@ import Prelude hiding (id) import Common.Model (Frequency (..), Payment (..), PaymentId, UserId) -import Model.Frequency () import Model.Query (Query (Query)) -import Resource (Resource, resourceCreatedAt, - resourceDeletedAt, - resourceEditedAt) +import Persistence.Frequency (FrequencyField (..)) -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt +newtype Row = Row Payment -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> +instance FromRow Row where + fromRow = Row <$> (Payment <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> + (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> SQLite.field <*> SQLite.field <*> - SQLite.field + SQLite.field) + +newtype InsertRow = InsertRow Payment -instance ToRow Payment where - toRow p = +instance ToRow InsertRow where + toRow (InsertRow p) = [ toField (_payment_user p) , toField (_payment_name p) , toField (_payment_cost p) , toField (_payment_date p) - , toField (_payment_frequency p) + , toField (FrequencyField (_payment_frequency p)) , toField (_payment_createdAt p) ] find :: PaymentId -> Query (Maybe Payment) find paymentId = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + Query (\conn -> do + fmap (\(Row p) -> p) . listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) ) listActive :: Query [Payment] listActive = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" ) listPunctual :: Query [Payment] listPunctual = - Query (\conn -> - SQLite.query - conn - (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") - (Only Punctual)) + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.query + conn + (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") + (Only (FrequencyField Punctual)) + ) listActiveMonthlyOrderedByName :: Query [Payment] listActiveMonthlyOrderedByName = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" - , "ORDER BY name DESC" - ]) - (Only Monthly)) + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) + (Only (FrequencyField Monthly)) + ) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId create userId paymentName paymentCost paymentDate paymentFrequency = @@ -102,7 +102,7 @@ create userId paymentName paymentCost paymentDate paymentFrequency = [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?)" ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -115,13 +115,13 @@ createMany payments = [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?)" ]) - payments + (map InsertRow payments) ) editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do - mbPayment <- listToMaybe <$> + mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> @@ -139,7 +139,7 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = , " frequency = ?" , "WHERE id = ?" ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) + (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId) return True else return False @@ -153,7 +153,7 @@ deleteOwn userId paymentId = mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of - Just payment -> + Just (Row payment) -> if _payment_user payment == userId then do now <- getCurrentTime diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index c60c1a2..1e377b1 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -1,6 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory +module Persistence.PaymentCategory ( list , listByCategory , save @@ -18,33 +16,40 @@ import qualified Common.Util.Text as T import Model.Query (Query (Query)) -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> +newtype Row = Row PaymentCategory + +instance FromRow Row where + fromRow = Row <$> (PaymentCategory <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field <*> - SQLite.field + SQLite.field) list :: Query [PaymentCategory] -list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") +list = + Query (\conn -> do + map (\(Row pc) -> pc) <$> + SQLite.query_ conn "SELECT * from payment_category" + ) listByCategory :: CategoryId -> Query [PaymentCategory] listByCategory cat = - Query (\conn -> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) + Query (\conn -> do + map (\(Row pc) -> pc) <$> + SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) ) save :: Text -> CategoryId -> Query () save newName categoryId = Query (\conn -> do now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> + hasPaymentCategory <- isJust <$> listToMaybe <$> (SQLite.query conn "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory + (Only (formatPaymentName newName)) :: IO [Row]) + if hasPaymentCategory then SQLite.execute conn diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs new file mode 100644 index 0000000..4ec2dcf --- /dev/null +++ b/server/src/Persistence/User.hs @@ -0,0 +1,37 @@ +module Persistence.User + ( list + , get + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (User (..)) + +import Model.Query (Query (Query)) + +newtype Row = Row User + +instance FromRow Row where + fromRow = Row <$> (User <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [User] +list = + Query (\conn -> do + map (\(Row u) -> u) <$> + SQLite.query_ conn "SELECT * from user ORDER BY creation DESC" + ) + +get :: Text -> Query (Maybe User) +get userEmail = + Query (\conn -> do + fmap (\(Row u) -> u) . listToMaybe <$> + SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + ) diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 6e5b998..4fb2333 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -16,7 +16,7 @@ import qualified LoginSession import Model.Query (Query) import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Model.User as User +import qualified Persistence.User as UserPersistence loggedAction :: (User -> ActionM ()) -> ActionM () loggedAction action = do @@ -39,6 +39,6 @@ getUserFromToken token = do mbSignIn <- SignIn.getSignIn token case mbSignIn of Just signIn -> - User.get (SignIn.email signIn) + UserPersistence.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index 3b17a0a..13d4072 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -43,6 +43,7 @@ mockMailMessage mail = T.concat $ , ")" , "\n" , body mail + , "\n" ] getMimeMail :: Mail -> M.Mail diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs index 3e0856d..4a29fcc 100644 --- a/server/src/Util/Time.hs +++ b/server/src/Util/Time.hs @@ -1,25 +1,22 @@ module Util.Time ( belongToCurrentMonth , belongToCurrentWeek - , timeToDay ) where -import Data.Time.Calendar +import Data.Time.Calendar (toGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime + +import qualified Common.Util.Time as Time belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + (timeYear, timeMonth, _) <- toGregorian <$> Time.timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= Time.timeToDay) return (actualYear == timeYear && actualMonth == timeMonth) belongToCurrentWeek :: UTCTime -> IO Bool belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + (timeYear, timeWeek, _) <- toWeekDate <$> Time.timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= Time.timeToDay) return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 5418880..7e88d98 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -2,28 +2,28 @@ module View.Mail.WeeklyReport ( mail ) where -import Data.List (sortOn) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (UTCTime) +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) -import Common.Model (ExceedingPayer (..), Income (..), - Payment (..), User (..), UserId) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (ExceedingPayer (..), Income (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Income () -import Model.Mail (Mail (Mail)) -import qualified Model.Mail as M -import Model.Payment () -import Resource (Status (..), groupByStatus, statuses) +import Conf (Conf) +import qualified Conf as Conf +import Model.IncomeResource (IncomeResource (..)) +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.PaymentResource (PaymentResource (..)) +import Resource (Status (..), groupByStatus, statuses) mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = @@ -42,8 +42,11 @@ body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text body conf users payments incomes start end = T.intercalate "\n" $ [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments) - , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes) + , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] + where + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text exceedingPayers conf time users incomes payments = @@ -58,7 +61,7 @@ exceedingPayers conf time users incomes payments = , "\n" ] -operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text operations conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then @@ -69,7 +72,7 @@ operations conf users paymentsByStatus incomesByStatus = , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses ] -paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text +paymentSection :: Status -> Conf -> [User] -> [PaymentResource] -> Text paymentSection status conf users payments = section sectionTitle sectionItems where count = length payments @@ -77,7 +80,7 @@ paymentSection status conf users payments = Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count - sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments + sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = @@ -89,7 +92,7 @@ payedFor status conf users payment = for = _payment_name payment at = Format.longDay $ _payment_date payment -incomeSection :: Status -> Conf -> [User] -> [Income] -> Text +incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text incomeSection status conf users incomes = section sectionTitle sectionItems where count = length incomes @@ -97,7 +100,7 @@ incomeSection status conf users incomes = Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count - sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = |