diff options
30 files changed, 302 insertions, 301 deletions
@@ -58,10 +58,25 @@ See [application.conf](application.conf). TODO ---- -- move persistence methods to a module -- use another route to check the token and redirect to / -- migration diff (use flyway?) +### Interface -- Add payment balance in weekly report -- search by payment category and payment date -- Move up element ids security (editOwn is actually at db level) +- Search payments by frequency. +- Add a payment. + +#### Bonus + +- Adjust login design. +- smooth search. +- search payments by: + - category, + - date. + +### Code + +- R.def for custom components. +- Move up element ids security (editOwn is actually at db level). +- move persistence methods to a module. + +### Tooling + +- migration diff (use flyway?). diff --git a/application.conf b/application.conf index 49b81a7..021fa2a 100644 --- a/application.conf +++ b/application.conf @@ -4,5 +4,6 @@ currency = "€" signInExpiration = 5 minutes noReplyMail = "no-reply@mail.com" https = False +devMode = True importMaybe "local.conf" diff --git a/client/client.cabal b/client/client.cabal index fdf764e..02a7549 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -39,7 +39,6 @@ Executable client View.App View.Header View.Payment - View.Payment.Constants View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 7eec7d0..24aac22 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -45,7 +45,7 @@ input inputIn = R.el "label" $ R.text (_inputIn_label inputIn) reset <- Button.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "reset" , _buttonIn_content = Icon.cross , _buttonIn_waiting = R.never } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 555d928..dae5e7f 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -29,8 +29,8 @@ cross = delete :: forall t m. MonadWidget t m => m () delete = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank doubleLeft :: forall t m. MonadWidget t m => m () doubleLeft = @@ -54,8 +54,8 @@ doubleRightBar = edit :: forall t m. MonadWidget t m => m () edit = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank loading :: forall t m. MonadWidget t m => m () loading = diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs new file mode 100644 index 0000000..f3e9c88 --- /dev/null +++ b/client/src/Util/Dom.hs @@ -0,0 +1,19 @@ +module Util.Dom + ( divVisibleIf + , divClassVisibleIf + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a +divVisibleIf cond content = divClassVisibleIf cond "" content + +divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a +divClassVisibleIf cond className content = + R.elDynAttr + "div" + (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) + content diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 8aa4d38..f4aaf5c 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -38,6 +38,8 @@ widget paymentIn = do (\s -> filter (filterPayment s) (_init_payments init)) (_headerOut_search header) + paymentsPerPage = 7 + header <- Header.widget $ HeaderIn { _headerIn_init = init } @@ -46,10 +48,13 @@ widget paymentIn = do { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages , _tableIn_payments = payments + , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_payments = payments + { _pagesIn_total = length <$> payments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header } return $ PaymentOut {} diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs deleted file mode 100644 index 028e328..0000000 --- a/client/src/View/Payment/Constants.hs +++ /dev/null @@ -1,6 +0,0 @@ -module View.Payment.Constants - ( paymentsPerPage - ) where - -paymentsPerPage :: Int -paymentsPerPage = 7 diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index dfd92c0..55ceb9f 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -4,20 +4,20 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment (..)) - -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon -import qualified View.Payment.Constants as Constants +import qualified Util.Dom as Dom data PagesIn t = PagesIn - { _pagesIn_payments :: Dynamic t [Payment] + { _pagesIn_total :: Dynamic t Int + , _pagesIn_perPage :: Int + , _pagesIn_reset :: Event t () } data PagesOut t = PagesOut @@ -26,9 +26,29 @@ data PagesOut t = PagesOut widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do + currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where + total = _pagesIn_total pagesIn + perPage = _pagesIn_perPage pagesIn + reset = _pagesIn_reset pagesIn + +pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) +pageButtons total perPage reset = do R.divClass "pages" $ do rec - currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] + currentPage <- R.holdDyn 1 . R.leftmost $ + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + , (const 1) <$> reset + ] firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -41,17 +61,10 @@ widget pagesIn = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return $ PagesOut - { _pagesOut_currentPage = currentPage - } - - where maxPage = - R.ffor (_pagesIn_payments pagesIn) (\payments -> - ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage - ) + return currentPage + where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) pageEvent = R.switchPromptlyDyn . fmap R.leftmost - noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0c3b769..a49be5c 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,28 +4,29 @@ 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 qualified Icon -import qualified View.Payment.Constants as Constants +import qualified Util.Dom as Dom data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int , _tableIn_payments :: Dynamic t [Payment] + , _tableIn_perPage :: Int } data TableOut = TableOut @@ -34,7 +35,8 @@ data TableOut = TableOut widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - _ <- R.divClass "table" $ + R.divClass "table" $ do + R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name @@ -45,17 +47,24 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - let init = _tableIn_init tableIn - currentPage = _tableIn_currentPage tableIn - payments = _tableIn_payments tableIn - paymentRange = getPaymentRange <$> payments <*> currentPage - R.simpleList paymentRange (paymentRow init) + _ <- R.simpleList paymentRange (paymentRow init) + return () + + Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + R.text $ Msg.get Msg.Payment_Empty + return $ TableOut {} -getPaymentRange :: [Payment] -> Int -> [Payment] -getPaymentRange payments currentPage = - take Constants.paymentsPerPage - . drop ((currentPage - 1) * Constants.paymentsPerPage) + where + init = _tableIn_init tableIn + currentPage = _tableIn_currentPage tableIn + payments = _tableIn_payments tableIn + paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage + +getPaymentRange :: Int -> [Payment] -> Int -> [Payment] +getPaymentRange perPage payments currentPage = + take perPage + . drop ((currentPage - 1) * perPage) . reverse . L.sortOn _payment_date $ payments diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index be6b152..89be737 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -45,7 +45,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "validate" , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } @@ -57,7 +57,7 @@ view result = 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 "/signIn" . SignIn) email + where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email getResult response = case R._xhrResponse_responseText response of Just key -> diff --git a/server/server.cabal b/server/server.cabal index 3715105..d1dbd50 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -36,7 +36,6 @@ Executable server , filepath , http-conduit , http-types - , lens , mime-mail , monad-logger , mtl @@ -61,7 +60,6 @@ Executable server Controller.Income Controller.Index Controller.Payment - Controller.SignIn Cookie Design.Color Design.Constants diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 2422a93..ca19c8d 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -17,6 +17,7 @@ data Conf = Conf , currency :: Currency , noReplyMail :: Text , https :: Bool + , devMode :: Bool } deriving Show get :: FilePath -> IO Conf @@ -30,7 +31,8 @@ get path = do Conf.lookup "signInExpiration" conf <*> fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> - Conf.lookup "https" conf + Conf.lookup "https" conf <*> + Conf.lookup "devMode" conf ) case conf of Left msg -> error (T.unpack msg) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f05ce6f..9a3e2b7 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,16 +1,23 @@ module Controller.Index ( get + , askSignIn + , trySignIn , signOut ) where import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Status (badRequest400, ok200) import Prelude hiding (error) -import Web.Scotty hiding (get) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (InitResult (..), User (..)) +import Common.Model (InitResult (..), SignIn (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg @@ -21,26 +28,52 @@ import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User import Secure (getUserFromToken) +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn import View.Page (page) -get :: Conf -> Maybe Text -> ActionM () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Msg.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult +get :: Conf -> ActionM () +get conf = do + initResult <- do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ 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 + case maybeUser of + Just user -> do + token <- liftIO . Query.run $ SignIn.createSignInToken email + let url = T.concat [ + if Conf.https conf then "https://" else "http://", + Conf.hostname conf, + "/signIn/", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + +trySignIn :: Conf -> Text -> ActionM () +trySignIn conf token = do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + Right _ -> + S.redirect "/" validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -82,4 +115,4 @@ getLoggedUser = do liftIO . Query.run . getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 +signOut conf = LoginSession.delete conf >> S.status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c6c874a..f2af6c9 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -22,7 +22,7 @@ import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json + (liftIO . Query.run $ Payment.listActive) >>= json ) create :: CreatePayment -> ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs deleted file mode 100644 index cf92c9f..0000000 --- a/server/src/Controller/SignIn.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty - -import Common.Model (SignIn (..)) -import qualified Common.Msg as Msg - -import Conf (Conf) -import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn - -signIn :: Conf -> SignIn -> ActionM () -signIn conf (SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 4d4be7b..7f5f503 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -23,7 +23,7 @@ design = do width (pct 100) marginBottom (px 10) - button ? do + button # ".validate" ? do Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten display flex alignItems center diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ca7e007..907be2b 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -12,7 +12,7 @@ import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly + monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName now <- getCurrentTime actualDay <- timeToDay now let punctualPayments = map diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 74180df..38d88b5 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -19,10 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) + (,,) <$> Payment.listPunctual <*> Income.list <*> User.list + _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now diff --git a/server/src/Main.hs b/server/src/Main.hs index c8080dc..e298a06 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,83 +1,62 @@ -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) - -import qualified Data.Text.Lazy as LT import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static -import Web.Scotty - -import Common.Model (Frequency (..), Payment (..)) -import qualified Common.Model as CM +import qualified Web.Scotty as S import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import qualified Data.Time as Time import Job.Daemon (runDaemons) -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query -import qualified Model.User as UserM main :: IO () main = do conf <- Conf.get "application.conf" _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } - middleware . staticPolicy $ noDots >-> addBase "public" + S.scotty (Conf.port conf) $ do + S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } + S.middleware . staticPolicy $ noDots >-> addBase "public" - get "/exceedingPayer" $ do - time <- liftIO Time.getCurrentTime - (users, incomes, payments) <- liftIO . Query.run $ - liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let punctualPayments = filter ((==) Punctual . _payment_frequency) payments - exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments - text . LT.pack . show $ exceedingPayers + S.get "/" $ do + Index.get conf - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken + S.post "/askSignIn" $ do + S.jsonData >>= Index.askSignIn conf - post "/signIn" $ do - jsonData >>= SignIn.signIn conf + S.get "/signIn/:signInToken" $ do + signInToken <- S.param "signInToken" + Index.trySignIn conf signInToken - post "/signOut" $ + S.post "/signOut" $ Index.signOut conf - post "/payment" $ - jsonData >>= Payment.create + S.post "/payment" $ + S.jsonData >>= Payment.create - put "/payment" $ - jsonData >>= Payment.editOwn + S.put "/payment" $ + S.jsonData >>= Payment.editOwn - delete "/payment" $ do - paymentId <- param "id" + S.delete "/payment" $ do + paymentId <- S.param "id" Payment.deleteOwn paymentId - post "/income" $ - jsonData >>= Income.create + S.post "/income" $ + S.jsonData >>= Income.create - put "/income" $ - jsonData >>= Income.editOwn + S.put "/income" $ + S.jsonData >>= Income.editOwn - delete "/income" $ do - incomeId <- param "id" + S.delete "/income" $ do + incomeId <- S.param "id" Income.deleteOwn incomeId - post "/category" $ - jsonData >>= Category.create + S.post "/category" $ + S.jsonData >>= Category.create - put "/category" $ - jsonData >>= Category.edit + S.put "/category" $ + S.jsonData >>= Category.edit - delete "/category" $ do - categoryId <- param "id" + S.delete "/category" $ do + categoryId <- S.param "id" Category.delete categoryId - -mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) -mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index a6174bc..4938e50 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -5,12 +5,11 @@ module Model.Income , create , editOwn , deleteOwn - , modifiedDuring ) where import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) @@ -87,12 +86,3 @@ deleteOwn user incomeId = Nothing -> return False ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Income] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" - (start, end, start, end, start, end) - ) diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index be44c72..0a0ffc7 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -18,7 +18,7 @@ getInit user conf = Init <$> User.list <*> (return . _user_id $ user) <*> - Payment.list <*> + Payment.listActive <*> Income.list <*> Category.list <*> PaymentCategory.list <*> diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs index a19f9ae..780efcc 100644 --- a/server/src/Model/Mail.hs +++ b/server/src/Model/Mail.hs @@ -5,8 +5,8 @@ module Model.Mail import Data.Text (Text) data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text - , plainBody :: Text + { from :: Text + , to :: [Text] + , subject :: Text + , body :: Text } deriving (Eq, Show) diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index 33551e5..5b29409 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -3,19 +3,18 @@ module Model.Payment ( Payment(..) , find - , list - , listMonthly + , listActive + , listPunctual + , listActiveMonthlyOrderedByName , create , createMany , editOwn , deleteOwn - , modifiedDuring ) where import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only), @@ -66,14 +65,22 @@ find paymentId = SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) ) -list :: Query [Payment] -list = +listActive :: Query [Payment] +listActive = Query (\conn -> SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" ) -listMonthly :: Query [Payment] -listMonthly = +listPunctual :: Query [Payment] +listPunctual = + Query (\conn -> + SQLite.query + conn + (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") + (Only Punctual)) + +listActiveMonthlyOrderedByName :: Query [Payment] +listActiveMonthlyOrderedByName = Query (\conn -> SQLite.query conn @@ -83,8 +90,7 @@ listMonthly = , "WHERE deleted_at IS NULL AND frequency = ?" , "ORDER BY name DESC" ]) - (Only Monthly) - ) + (Only Monthly)) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId create userId paymentName paymentCost paymentDate paymentFrequency = @@ -161,18 +167,3 @@ deleteOwn userId paymentId = Nothing -> return False ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE (created_at >= ? AND created_at <= ?)" - , " OR (edited_at >= ? AND edited_at <= ?)" - , " OR (deleted_at >= ? AND deleted_at <= ?)" - ]) - (start, end, start, end, start, end) - ) diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index c15ed62..3b17a0a 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -9,18 +9,41 @@ import qualified Network.Mail.Mime as M import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (fromText, toLazyText) -import Model.Mail (Mail (Mail)) +import Conf (Conf) +import qualified Conf +import Model.Mail (Mail (..)) -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = do - result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) - if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) - else putStrLn "OK" - return result +sendMail :: Conf -> Mail -> IO (Either Text ()) +sendMail conf mail = + if Conf.devMode conf + then + do + T.putStrLn . mockMailMessage $ mail + return (Right ()) + else + do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else return () + return result + +mockMailMessage :: Mail -> Text +mockMailMessage mail = T.concat $ + [ "[MOCK MAIL] " + , subject mail + , " (from: " + , from mail + , ") (to: " + , T.intercalate ", " $ to mail + , ")" + , "\n" + , body mail + ] getMimeMail :: Mail -> M.Mail getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index 22c3cb0..3c5469f 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -17,5 +17,5 @@ mail conf user url to = { M.from = Conf.noReplyMail conf , M.to = to , M.subject = Msg.get Msg.SignIn_MailTitle - , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url) + , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url) } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 4ad8b77..5418880 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -11,8 +11,8 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) -import Common.Model (Income (..), Payment (..), User (..), - UserId) +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 @@ -35,11 +35,31 @@ mail conf users payments incomes start end = , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) + , M.body = body conf users payments incomes start end } -body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text -body conf users paymentsByStatus incomesByStatus = +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) + ] + +exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text +exceedingPayers conf time users incomes payments = + T.intercalate "\n" . map formatPayer $ payers + where + payers = CM.getExceedingPayers time users incomes payments + formatPayer p = T.concat + [ " * " + , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users + , " + " + , Format.price (Conf.currency conf) $ _exceedingPayer_amount p + , "\n" + ] + +operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +operations conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then Msg.get Msg.WeeklyReport_Empty @@ -96,5 +116,5 @@ section title items = T.concat [ title , "\n\n" - , T.unlines . map (" - " <>) $ items + , T.unlines . map (" * " <>) $ items ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 27b4f26..97b84fa 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -26,10 +26,10 @@ page initResult = meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" H.title (toHtml $ Msg.get Msg.App_Title) - script ! src "javascript/main.js" $ "" + script ! src "/javascript/main.js" $ "" jsonScript "init" initResult - link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" - link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign jsonScript :: Json.ToJSON a => Text -> a -> Html diff --git a/stylish-haskell/default.nix b/stylish-haskell/default.nix deleted file mode 100644 index bd73cf8..0000000 --- a/stylish-haskell/default.nix +++ /dev/null @@ -1,44 +0,0 @@ -{ HUnit, aeson, base, bytestring, containers, directory, fetchFromGitHub -, filepath, haskell-src-exts, mkDerivation, mtl, optparse-applicative, stdenv -, strict, stylish-haskell, syb, test-framework, test-framework-hunit, yaml -}: - -let regularDependencies = [ - aeson - base - bytestring - containers - directory - filepath - haskell-src-exts - mtl - syb - yaml - ]; -in mkDerivation { - pname = "stylish-haskell"; - version = "0.8.1.0"; - - src = fetchFromGitHub { - owner = "jaspervdj"; - repo = "stylish-haskell"; - rev = "dc3a73e82c19ff97a1544840dac8f7f4568b24bc"; - sha256 = "0kx9m3j9w2357ff5y651s9cdbjiyax9fksyf4rk8pzabc0dv6dpg"; - }; - - isLibrary = true; - isExecutable = true; - - libraryHaskellDepends = - regularDependencies; - - executableHaskellDepends = - regularDependencies ++ [ optparse-applicative strict stylish-haskell ]; - - testHaskellDepends = - regularDependencies ++ [ HUnit test-framework test-framework-hunit ]; - - homepage = "https://github.com/jaspervdj/stylish-haskell"; - description = "Simple Haskell code prettifier"; - license = stdenv.lib.licenses.bsd3; - } @@ -7,11 +7,12 @@ with import <nixpkgs> {}; { cabal-install tmux tmuxinator - (import ./stylish-haskell { - inherit mkDerivation aeson base bytestring containers directory filepath - fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict - optparse-applicative HUnit test-framework test-framework-hunit stdenv; - }) + stylish-haskell + # (import ./stylish-haskell { + # inherit mkDerivation aeson base bytestring containers directory filepath + # fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict + # optparse-applicative HUnit test-framework test-framework-hunit stdenv; + # }) ]; }; } |