From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- server/src/Conf.hs | 39 ++ server/src/Controller/Category.hs | 53 +++ server/src/Controller/Income.hs | 48 +++ server/src/Controller/Index.hs | 86 ++++ server/src/Controller/Payment.hs | 58 +++ server/src/Controller/SignIn.hs | 47 +++ server/src/Cookie.hs | 56 +++ server/src/Design/Color.hs | 35 ++ server/src/Design/Constants.hs | 27 ++ server/src/Design/Dialog.hs | 24 ++ server/src/Design/Errors.hs | 55 +++ server/src/Design/Form.hs | 130 ++++++ server/src/Design/Global.hs | 75 ++++ server/src/Design/Helper.hs | 90 +++++ server/src/Design/Media.hs | 36 ++ server/src/Design/Tooltip.hs | 16 + server/src/Design/View/Header.hs | 78 ++++ server/src/Design/View/Payment.hs | 17 + server/src/Design/View/Payment/Header.hs | 84 ++++ server/src/Design/View/Payment/Pages.hs | 54 +++ server/src/Design/View/Payment/Table.hs | 42 ++ server/src/Design/View/SignIn.hs | 42 ++ server/src/Design/View/Stat.hs | 15 + server/src/Design/View/Table.hs | 84 ++++ server/src/Design/Views.hs | 49 +++ server/src/Job/Daemon.hs | 36 ++ server/src/Job/Frequency.hs | 13 + server/src/Job/Kind.hs | 22 + server/src/Job/Model.hs | 47 +++ server/src/Job/MonthlyPayment.hs | 26 ++ server/src/Job/WeeklyReport.hs | 28 ++ server/src/Json.hs | 19 + server/src/LoginSession.hs | 53 +++ server/src/Main.hs | 79 ++++ server/src/MimeMail.hs | 672 +++++++++++++++++++++++++++++++ server/src/Model/Category.hs | 79 ++++ server/src/Model/Frequency.hs | 22 + server/src/Model/Income.hs | 97 +++++ server/src/Model/Init.hs | 27 ++ server/src/Model/Mail.hs | 12 + server/src/Model/Payer.hs | 216 ++++++++++ server/src/Model/Payment.hs | 175 ++++++++ server/src/Model/PaymentCategory.hs | 62 +++ server/src/Model/Query.hs | 32 ++ server/src/Model/SignIn.hs | 66 +++ server/src/Model/UUID.hs | 10 + server/src/Model/User.hs | 49 +++ server/src/Resource.hs | 54 +++ server/src/Secure.hs | 47 +++ server/src/SendMail.hs | 44 ++ server/src/Utils/Time.hs | 25 ++ server/src/Validation.hs | 23 ++ server/src/View/Mail/SignIn.hs | 24 ++ server/src/View/Mail/WeeklyReport.hs | 102 +++++ server/src/View/Page.hs | 43 ++ 55 files changed, 3544 insertions(+) create mode 100644 server/src/Conf.hs create mode 100644 server/src/Controller/Category.hs create mode 100644 server/src/Controller/Income.hs create mode 100644 server/src/Controller/Index.hs create mode 100644 server/src/Controller/Payment.hs create mode 100644 server/src/Controller/SignIn.hs create mode 100644 server/src/Cookie.hs create mode 100644 server/src/Design/Color.hs create mode 100644 server/src/Design/Constants.hs create mode 100644 server/src/Design/Dialog.hs create mode 100644 server/src/Design/Errors.hs create mode 100644 server/src/Design/Form.hs create mode 100644 server/src/Design/Global.hs create mode 100644 server/src/Design/Helper.hs create mode 100644 server/src/Design/Media.hs create mode 100644 server/src/Design/Tooltip.hs create mode 100644 server/src/Design/View/Header.hs create mode 100644 server/src/Design/View/Payment.hs create mode 100644 server/src/Design/View/Payment/Header.hs create mode 100644 server/src/Design/View/Payment/Pages.hs create mode 100644 server/src/Design/View/Payment/Table.hs create mode 100644 server/src/Design/View/SignIn.hs create mode 100644 server/src/Design/View/Stat.hs create mode 100644 server/src/Design/View/Table.hs create mode 100644 server/src/Design/Views.hs create mode 100644 server/src/Job/Daemon.hs create mode 100644 server/src/Job/Frequency.hs create mode 100644 server/src/Job/Kind.hs create mode 100644 server/src/Job/Model.hs create mode 100644 server/src/Job/MonthlyPayment.hs create mode 100644 server/src/Job/WeeklyReport.hs create mode 100644 server/src/Json.hs create mode 100644 server/src/LoginSession.hs create mode 100644 server/src/Main.hs create mode 100644 server/src/MimeMail.hs create mode 100644 server/src/Model/Category.hs create mode 100644 server/src/Model/Frequency.hs create mode 100644 server/src/Model/Income.hs create mode 100644 server/src/Model/Init.hs create mode 100644 server/src/Model/Mail.hs create mode 100644 server/src/Model/Payer.hs create mode 100644 server/src/Model/Payment.hs create mode 100644 server/src/Model/PaymentCategory.hs create mode 100644 server/src/Model/Query.hs create mode 100644 server/src/Model/SignIn.hs create mode 100644 server/src/Model/UUID.hs create mode 100644 server/src/Model/User.hs create mode 100644 server/src/Resource.hs create mode 100644 server/src/Secure.hs create mode 100644 server/src/SendMail.hs create mode 100644 server/src/Utils/Time.hs create mode 100644 server/src/Validation.hs create mode 100644 server/src/View/Mail/SignIn.hs create mode 100644 server/src/View/Mail/WeeklyReport.hs create mode 100644 server/src/View/Page.hs (limited to 'server/src') diff --git a/server/src/Conf.hs b/server/src/Conf.hs new file mode 100644 index 0000000..26c5c28 --- /dev/null +++ b/server/src/Conf.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Conf + ( get + , Conf(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ConfigManager as Conf +import Data.Time.Clock (NominalDiffTime) + +import Common.Model (Currency(..)) + +data Conf = Conf + { hostname :: Text + , port :: Int + , signInExpiration :: NominalDiffTime + , currency :: Currency + , noReplyMail :: Text + , https :: Bool + } deriving Show + +get :: FilePath -> IO Conf +get path = do + conf <- + (flip fmap) (Conf.readConfig path) (\configOrError -> do + conf <- configOrError + Conf <$> + Conf.lookup "hostname" conf <*> + Conf.lookup "port" conf <*> + Conf.lookup "signInExpiration" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> + Conf.lookup "noReplyMail" conf <*> + Conf.lookup "https" conf + ) + case conf of + Left msg -> error (T.unpack msg) + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..d6ed2f2 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Category + ( create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty hiding (delete) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) + +import Json (jsonId) +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +create :: CreateCategory -> ActionM () +create (CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Category.create name color) >>= jsonId + ) + +edit :: EditCategory -> ActionM () +edit (EditCategory categoryId name color) = + Secure.loggedAction (\_ -> do + updated <- liftIO . Query.run $ Category.edit categoryId name color + if updated + then status ok200 + else status badRequest400 + ) + +delete :: CategoryId -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . Query.run $ do + paymentCategories <- PaymentCategory.listByCategory categoryId + if null paymentCategories + then Category.delete categoryId + else return False + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Category_NotDeleted + ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..148b713 --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Income + ( create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query +import qualified Secure + +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = + Secure.loggedAction (\user -> + (liftIO . Query.run $ Income.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 + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: IncomeId -> ActionM () +deleteOwn incomeId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Income_NotDeleted + ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..8473c5c --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,86 @@ +module Controller.Index + ( get + , signOut + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) + +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + +import Conf (Conf(..)) +import Model.Init (getInit) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import Secure (getUserFromToken) +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 . Message.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 + +validateSignIn :: Conf -> Text -> ActionM (Either Key User) +validateSignIn conf textToken = do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Just loggedUser -> + return . Right $ loggedUser + Nothing -> do + mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken + now <- liftIO getCurrentTime + case mbSignIn of + Nothing -> + return . Left $ Key.SignIn_LinkInvalid + Just signIn -> + if SignIn.isUsed signIn + then + return . Left $ Key.SignIn_LinkUsed + else + let diffTime = now `diffUTCTime` (SignIn.creation signIn) + in if diffTime > signInExpiration conf + then + return . Left $ Key.SignIn_LinkExpired + else do + LoginSession.put conf (SignIn.token signIn) + mbUser <- liftIO . Query.run $ do + SignIn.signInTokenToUsed . SignIn.id $ signIn + User.get . SignIn.email $ signIn + return $ case mbUser of + Nothing -> Left Key.Secure_Unauthorized + Just user -> Right user + +getLoggedUser :: ActionM (Maybe User) +getLoggedUser = do + mbToken <- LoginSession.get + case mbToken of + Nothing -> + return Nothing + Just token -> do + liftIO . Query.run . getUserFromToken $ token + +signOut :: Conf -> ActionM () +signOut conf = LoginSession.delete conf >> status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..dc10311 --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Payment + ( list + , create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import Web.Scotty + +import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) + +import Json (jsonId) +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Payment.list) >>= 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 + ) + +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 + _ <- if edited + then PaymentCategory.save name category >> return () + else return () + return edited + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: PaymentId -> ActionM () +deleteOwn paymentId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId + if deleted + then status ok200 + else status badRequest400 + ) diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs new file mode 100644 index 0000000..0086fa5 --- /dev/null +++ b/server/src/Controller/SignIn.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.SignIn + ( signIn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(..)) + +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 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs new file mode 100644 index 0000000..96d45da --- /dev/null +++ b/server/src/Cookie.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cookie + ( makeSimpleCookie + , setCookie + , setSimpleCookie + , getCookie + , getCookies + , deleteCookie + ) where + +import Control.Monad ( liftM ) + +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL + +import Conf (Conf) +import qualified Conf + +import qualified Data.Map as Map + +import qualified Data.ByteString.Lazy as BSL + +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) + +import Blaze.ByteString.Builder ( toLazyByteString ) + +import Web.Scotty.Trans +import Web.Cookie + +makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie +makeSimpleCookie conf name value = + def + { setCookieName = TS.encodeUtf8 name + , setCookieValue = TS.encodeUtf8 value + , setCookiePath = Just $ TS.encodeUtf8 "/" + , setCookieSecure = Conf.https conf + } + +setCookie :: (Monad m) => SetCookie -> ActionT e m () +setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) + +setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () +setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value + +getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) +getCookie name = liftM (Map.lookup name) getCookies + +getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) +getCookies = + liftM (Map.fromList . maybe [] parse) $ header "Cookie" + where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 + +deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () +deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs new file mode 100644 index 0000000..06c468e --- /dev/null +++ b/server/src/Design/Color.hs @@ -0,0 +1,35 @@ +module Design.Color where + +import qualified Clay.Color as C + +-- http://chir.ag/projects/name-that-color/#969696 + +white :: C.Color +white = C.white + +black :: C.Color +black = C.black + +chestnutRose :: C.Color +chestnutRose = C.rgb 207 92 86 + +unknown :: C.Color +unknown = C.rgb 86 92 207 + +mossGreen :: C.Color +mossGreen = C.rgb 159 210 165 + +gothic :: C.Color +gothic = C.rgb 108 162 164 + +negroni :: C.Color +negroni = C.rgb 255 223 196 + +wildSand :: C.Color +wildSand = C.rgb 245 245 245 + +silver :: C.Color +silver = C.rgb 200 200 200 + +dustyGray :: C.Color +dustyGray = C.rgb 150 150 150 diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs new file mode 100644 index 0000000..4e2b8cc --- /dev/null +++ b/server/src/Design/Constants.hs @@ -0,0 +1,27 @@ +module Design.Constants where + +import Clay + +iconFontSize :: Size LengthUnit +iconFontSize = px 32 + +radius :: Size LengthUnit +radius = px 3 + +blockPadding :: Size LengthUnit +blockPadding = px 15 + +blockPercentWidth :: Double +blockPercentWidth = 90 + +blockPercentMargin :: Double +blockPercentMargin = (100 - blockPercentWidth) / 2 + +inputHeight :: Double +inputHeight = 40 + +focusLighten :: Color -> Color +focusLighten baseColor = baseColor +. 20 + +focusDarken :: Color -> Color +focusDarken baseColor = baseColor -. 20 diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs new file mode 100644 index 0000000..4678633 --- /dev/null +++ b/server/src/Design/Dialog.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Dialog + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +design :: Css +design = do + + ".content" ? do + minWidth (px 270) + + ".paymentDialog" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do + h1 ? marginBottom (em 1.5) diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs new file mode 100644 index 0000000..57aaeee --- /dev/null +++ b/server/src/Design/Errors.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Errors + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + position fixed + top (px 20) + left (pct 50) + "transform" -: "translateX(-50%)" + margin (px 0) (px 0) (px 0) (px 0) + disapearKeyframes + + ".error" ? do + disapearAnimation + let errorColor = Color.chestnutRose -. 15 + color errorColor + border solid (px 2) errorColor + backgroundColor Color.white + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + + before & display none + +disapearAnimation :: Css +disapearAnimation = do + animationName "disapear" + animationDelay (sec 5) + animationDuration (sec 1) + animationFillMode forwards + +disapearKeyframes :: Css +disapearKeyframes = keyframes + "disapear" + [ ( 10 + , do + opacity 0 + height (px 40) + lineHeight (px 40) + marginBottom (px 10) + ) + , ( 100 + , do + opacity 0 + height (px 0) + lineHeight (px 0) + marginBottom (px 0) + ) + ] diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs new file mode 100644 index 0000000..ebb8ac8 --- /dev/null +++ b/server/src/Design/Form.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Form + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color + +design :: Css +design = do + + let inputHeight = 30 + let inputTop = 22 + let inputPaddingBottom = 3 + let inputZIndex = 1 + + label ? do + cursor pointer + color Color.silver + + ".textInput" ? do + position relative + marginBottom (em 1.5) + paddingTop (px inputTop) + marginTop (px (-10)) + + input ? do + width (pct 100) + position relative + zIndex inputZIndex + backgroundColor transparent + paddingBottom (px inputPaddingBottom) + borderStyle none + borderBottom solid (px 1) Color.dustyGray + marginBottom (px 5) + height (px inputHeight) + lineHeight (px inputHeight) + focus & do + borderWidth (px 2) + paddingBottom (px $ inputPaddingBottom - 1) + + label ? do + lineHeight (px inputHeight) + position absolute + top (px inputTop) + left (px 0) + transition "all" (sec 0.2) easeIn (sec 0) + + button ? do + position absolute + right (px 0) + top (px 27) + zIndex inputZIndex + hover & "svg path" ? do + "fill" -: "rgb(220, 220, 220)" + + (input # ".filled" |+ label) <> (input # focus |+ label) ? do + top (px 0) + fontSize (pct 80) + + ".error" & do + input ? do + borderBottomColor Color.chestnutRose + + ".errorMessage" ? do + position absolute + color Color.chestnutRose + fontSize (pct 80) + + ".colorInput" ? do + display flex + alignItems center + marginBottom (em 1.5) + + input ? do + borderColor transparent + backgroundColor transparent + + ".radioGroup" ? do + position relative + marginBottom (em 2) + + ".title" ? do + color Color.silver + marginBottom (em 0.8) + + ".radioInputs" ? do + display flex + "justify-content" -: "center" + + ".radioInput:not(:last-child)::after" ? do + content (stringContent "/") + marginLeft (px 10) + marginRight (px 10) + + input ? do + opacity 0 + width (px 30) + margin (px 0) (px (-15)) (px 0) (px (-15)) + + "input:focus + label" ? do + textDecoration underline + + "input:checked + label" ? do + color Color.chestnutRose + fontWeight bold + + ".selectInput" ? do + label ? do + display block + marginBottom (px 10) + fontSize (pct 80) + select ? do + 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) + ".error" & do + select ? borderColor Color.chestnutRose + ".errorMessage" ? do + color Color.chestnutRose + fontSize (pct 80) + marginTop (em 0.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs new file mode 100644 index 0000000..47ea4a9 --- /dev/null +++ b/server/src/Design/Global.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Global + ( globalDesign + ) where + +import Clay + +import Data.Text.Lazy (Text) + +import qualified Design.Views as Views +import qualified Design.Form as Form +import qualified Design.Errors as Errors +import qualified Design.Dialog as Dialog +import qualified Design.Tooltip as Tooltip + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +globalDesign :: Text +globalDesign = renderWith compact [] global + +global :: Css +global = do + ".errors" ? Errors.design + ".dialog" ? Dialog.design + ".tooltip" ? Tooltip.design + Views.design + Form.design + + body ? do + minWidth (px 320) + fontFamily ["Cantarell"] [sansSerif] + Media.tablet $ do + fontSize (px 15) + button ? fontSize (px 15) + input ? fontSize (px 15) + Media.mobile $ do + fontSize (px 14) + button ? fontSize (px 14) + input ? fontSize (px 14) + + a ? cursor pointer + + input ? fontSize inherit + + h1 ? do + color Color.chestnutRose + marginBottom (em 1) + lineHeight (em 1.2) + + Media.desktop $ fontSize (px 24) + Media.tablet $ fontSize (px 22) + Media.mobile $ fontSize (px 20) + + ul ? do + "margin-bottom" -: "3vh" + "margin-left" -: "1vh" + li Color -> Size a -> (Color -> Color) -> Css +button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center + backgroundColor backgroundCol + padding (px 0) (px 10) (px 0) (px 10) + color textCol + borderRadius radius radius radius radius + verticalAlign middle + cursor pointer + lineHeight h + height h + textAlign (alignSide sideCenter) + hover & backgroundColor (focusOp backgroundCol) + focus & backgroundColor (focusOp backgroundCol) + waitable + +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation + +input :: Double -> Css +input h = do + height (px h) + padding (px 10) (px 10) (px 10) (px 10) + borderRadius radius radius radius radius + border solid (px 1) Color.dustyGray + focus & borderColor Color.silver + verticalAlign middle + +centeredWithMargin :: Css +centeredWithMargin = do + width (pct blockPercentWidth) + marginLeft auto + marginRight auto + +verticalCentering :: Css +verticalCentering = do + position absolute + top (pct 50) + "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs new file mode 100644 index 0000000..77220ee --- /dev/null +++ b/server/src/Design/Media.hs @@ -0,0 +1,36 @@ +module Design.Media + ( mobile + , mobileTablet + , tablet + , tabletDesktop + , desktop + ) where + +import Clay hiding (query) +import qualified Clay +import Clay.Stylesheet (Feature) +import qualified Clay.Media as Media + +mobile :: Css -> Css +mobile = query [Media.maxWidth mobileTabletLimit] + +mobileTablet :: Css -> Css +mobileTablet = query [Media.maxWidth tabletDesktopLimit] + +tablet :: Css -> Css +tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] + +tabletDesktop :: Css -> Css +tabletDesktop = query [Media.minWidth mobileTabletLimit] + +desktop :: Css -> Css +desktop = query [Media.minWidth tabletDesktopLimit] + +query :: [Feature] -> Css -> Css +query = Clay.query Media.screen + +mobileTabletLimit :: Size LengthUnit +mobileTabletLimit = (px 520) + +tabletDesktopLimit :: Size LengthUnit +tabletDesktopLimit = (px 950) diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs new file mode 100644 index 0000000..1da8764 --- /dev/null +++ b/server/src/Design/Tooltip.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Tooltip + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + color Color.white diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs new file mode 100644 index 0000000..20627e6 --- /dev/null +++ b/server/src/Design/View/Header.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + let headerPadding = "padding" -: "0 20px" + display flex + "flex-wrap" -: "wrap" + lineHeightMedia + position relative + backgroundColor Color.chestnutRose + color Color.white + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + Media.mobile $ marginBottom (em 1.5) + + ".title" <> ".item" ? headerPadding + + ".title" ? do + height (pct 100) + textAlign (alignSide sideLeft) + + Media.mobile $ fontSize (px 22) + Media.mobileTablet $ width (pct 100) + Media.tabletDesktop $ do + display inlineBlock + fontSize (px 35) + + ".item" ? do + display inlineBlock + transition "background-color" (ms 50) easeIn (sec 0) + ".current" & backgroundColor (Color.chestnutRose -. 20) + Media.mobile $ fontSize (px 13) + + (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) + (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + + ".nameSignOut" ? do + display flex + heightMedia + position absolute + top (px 0) + right (px 0) + + ".name" ? do + Media.mobile $ display none + Media.tabletDesktop $ headerPadding + + ".signOut" ? do + Helper.waitable + heightMedia + svg ? do + Media.tabletDesktop $ width (px 30) + Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") + +lineHeightMedia :: Css +lineHeightMedia = do + Media.desktop $ lineHeight (px 80) + Media.tablet $ lineHeight (px 65) + Media.mobile $ lineHeight (px 50) + +heightMedia :: Css +heightMedia = do + Media.desktop $ height (px 80) + Media.tablet $ height (px 65) + Media.mobile $ height (px 50) diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/server/src/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs new file mode 100644 index 0000000..f02da8a --- /dev/null +++ b/server/src/Design/View/Payment/Header.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Constants + +import qualified Design.Helper as Helper +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + marginLeft (pct blockPercentMargin) + marginRight (pct blockPercentMargin) + + ".payerAndAdd" ? do + Media.tabletDesktop $ display flex + marginBottom (em 1) + + ".exceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + + Media.tabletDesktop $ do + "flex-grow" -: "1" + marginRight (px 15) + + Media.mobile $ do + marginBottom (em 1) + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + + ".searchLine" ? do + marginBottom (em 1) + form ? do + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none + + ".infos" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs new file mode 100644 index 0000000..ade81a8 --- /dev/null +++ b/server/src/Design/View/Payment/Pages.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + textAlign (alignSide sideCenter) + Helper.clearFix + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs new file mode 100644 index 0000000..a866b40 --- /dev/null +++ b/server/src/Design/View/Payment/Table.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Table + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".cell" ? do + ".name" & do + Media.tabletDesktop $ width (pct 30) + + ".cost" & do + Media.tabletDesktop $ width (pct 10) + + ".user" & do + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) + + ".date" & do + Media.tabletDesktop $ width (pct 15) + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/server/src/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs new file mode 100644 index 0000000..0a5b258 --- /dev/null +++ b/server/src/Design/View/Stat.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Stat + ( design + ) where + +import Clay + +design :: Css +design = do + h1 ? paddingBottom (px 0) + + ".exceedingPayers" ? ".userName" ? marginRight (px 5) + + ".mean" ? marginBottom (em 1.5) diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs new file mode 100644 index 0000000..95abf90 --- /dev/null +++ b/server/src/Design/View/Table.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Table + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".emptyTableMsg" ? do + margin (em 2) (em 2) (em 2) (em 2) + textAlign (alignSide sideCenter) + + ".lines" ? do + Media.tabletDesktop $ display displayTable + width (pct 100) + textAlign (alignSide (sideCenter)) + + ".header" <> ".row" ? do + Media.tabletDesktop $ display tableRow + + ".header" ? do + Media.desktop $ do + fontSize (px 18) + height (px 70) + + Media.tabletDesktop $ do + backgroundColor Color.gothic + color Color.white + + Media.tablet $ do + fontSize (px 16) + height (px 60) + + Media.mobile $ do + display none + + ".row" ? do + nthChild "even" & backgroundColor Color.wildSand + + Media.desktop $ do + fontSize (px 18) + height (px 60) + + Media.tablet $ do + height (px 50) + + Media.mobile $ do + lineHeight (px 25) + paddingTop (px 10) + paddingBottom (px 10) + + ".cell" ? do + Media.tabletDesktop $ display tableCell + position relative + verticalAlign middle + + firstChild & do + Media.mobile $ do + fontSize (px 20) + lineHeight (px 30) + color Color.gothic + + ".refund" & color Color.mossGreen + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + hover & "svg path" ? do + "fill" -: "rgb(237, 122, 116)" + + Media.tabletDesktop $ width (pct 3) + + Media.mobile $ do + display inlineBlock + button ? display flex diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs new file mode 100644 index 0000000..bc6ac83 --- /dev/null +++ b/server/src/Design/Views.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.View.Header as Header +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design + ".stat" ? Stat.design + Table.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs new file mode 100644 index 0000000..0bc6f6e --- /dev/null +++ b/server/src/Job/Daemon.hs @@ -0,0 +1,36 @@ +module Job.Daemon + ( runDaemons + ) where + +import Control.Concurrent (threadDelay, forkIO, ThreadId) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) + +import Conf (Conf) +import Job.Frequency (Frequency(..), microSeconds) +import Job.Kind (Kind(..)) +import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) + +runDaemons :: Conf -> IO () +runDaemons conf = do + _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment + _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) + return () + +runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId +runDaemon kind frequency isLastExecutionTooOld runJob = + forkIO . forever $ do + mbLastExecution <- Query.run $ do + actualizeLastCheck kind + getLastExecution kind + hasToRun <- case mbLastExecution of + Just lastExecution -> isLastExecutionTooOld lastExecution + Nothing -> return True + if hasToRun + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) + else return () + threadDelay . microSeconds $ frequency diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs new file mode 100644 index 0000000..263f6e6 --- /dev/null +++ b/server/src/Job/Frequency.hs @@ -0,0 +1,13 @@ +module Job.Frequency + ( Frequency(..) + , microSeconds + ) where + +data Frequency = + EveryHour + | EveryDay + deriving (Eq, Read, Show) + +microSeconds :: Frequency -> Int +microSeconds EveryHour = 1000000 * 60 * 60 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs new file mode 100644 index 0000000..af5d4f8 --- /dev/null +++ b/server/src/Job/Kind.hs @@ -0,0 +1,22 @@ +module Job.Kind + ( Kind(..) + ) where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +data Kind = + MonthlyPayment + | WeeklyReport + deriving (Eq, Show, Read) + +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs new file mode 100644 index 0000000..e1a3c77 --- /dev/null +++ b/server/src/Job/Model.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Job.Model + ( Job(..) + , getLastExecution + , actualizeLastExecution + , actualizeLastCheck + ) where + +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Job.Kind +import Model.Query (Query(Query)) + +data Job = Job + { id :: String + , kind :: Kind + , lastExecution :: Maybe UTCTime + , lastCheck :: Maybe UTCTime + } deriving (Show) + +getLastExecution :: Kind -> Query (Maybe UTCTime) +getLastExecution jobKind = + Query (\conn -> do + [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] + return time + ) + +actualizeLastExecution :: Kind -> UTCTime -> Query () +actualizeLastExecution jobKind time = + Query (\conn -> do + [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] + if isJust result + then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) + else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) + ) + +actualizeLastCheck :: Kind -> Query () +actualizeLastCheck jobKind = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) + ) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs new file mode 100644 index 0000000..ba24cca --- /dev/null +++ b/server/src/Job/MonthlyPayment.hs @@ -0,0 +1,26 @@ +module Job.MonthlyPayment + ( monthlyPayment + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (Frequency(..), Payment(..)) + +import qualified Model.Payment as Payment +import Utils.Time (timeToDay) +import qualified Model.Query as Query + +monthlyPayment :: Maybe UTCTime -> IO UTCTime +monthlyPayment _ = do + monthlyPayments <- Query.run Payment.listMonthly + now <- getCurrentTime + actualDay <- timeToDay now + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments + _ <- Query.run (Payment.createMany punctualPayments) + return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs new file mode 100644 index 0000000..5737c75 --- /dev/null +++ b/server/src/Job/WeeklyReport.hs @@ -0,0 +1,28 @@ +module Job.WeeklyReport + ( weeklyReport + ) where + +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 SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport + +weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime +weeklyReport conf mbLastExecution = do + now <- getCurrentTime + case mbLastExecution of + 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) + return () + return now diff --git a/server/src/Json.hs b/server/src/Json.hs new file mode 100644 index 0000000..cc6327a --- /dev/null +++ b/server/src/Json.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Json + ( jsonObject + , jsonId + ) where + +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Aeson.Types as Json +import qualified Data.HashMap.Strict as M +import Web.Scotty + +jsonObject :: [(Text, Json.Value)] -> ActionM () +jsonObject = json . Json.Object . M.fromList + +jsonId :: Int64 -> ActionM () +jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs new file mode 100644 index 0000000..6f6d620 --- /dev/null +++ b/server/src/LoginSession.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LoginSession + ( put + , get + , delete + ) where + +import Web.Scotty (ActionM) +import Cookie (setSimpleCookie, getCookie, deleteCookie) +import qualified Web.ClientSession as CS + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Conf (Conf) + +sessionName :: Text +sessionName = "SESSION" + +sessionKeyFile :: FilePath +sessionKeyFile = "sessionKey" + +put :: Conf -> Text -> ActionM () +put conf value = do + encrypted <- liftIO $ encrypt value + setSimpleCookie conf sessionName encrypted + +encrypt :: Text -> IO Text +encrypt value = do + iv <- CS.randomIV + key <- CS.getKey sessionKeyFile + return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) + +get :: ActionM (Maybe Text) +get = do + maybeEncrypted <- getCookie sessionName + case maybeEncrypted of + Just encrypted -> + liftIO $ decrypt encrypted + Nothing -> + return Nothing + +decrypt :: Text -> IO (Maybe Text) +decrypt encrypted = do + key <- CS.getKey sessionKeyFile + let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) + return decrypted + +delete :: Conf -> ActionM () +delete conf = deleteCookie conf sessionName diff --git a/server/src/Main.hs b/server/src/Main.hs new file mode 100644 index 0000000..db73474 --- /dev/null +++ b/server/src/Main.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + +import Network.Wai.Middleware.Static +import qualified Data.Text.Lazy as LT +import Web.Scotty + +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 Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query + +main :: IO () +main = do + conf <- Conf.get "application.conf" + _ <- runDaemons conf + scotty (Conf.port conf) $ do + 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 exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + + get "/" $ do + signInToken <- mbParam "signInToken" + Index.get conf signInToken + + post "/signIn" $ do + jsonData >>= SignIn.signIn conf + + post "/signOut" $ + Index.signOut conf + + post "/payment" $ + jsonData >>= Payment.create + + put "/payment" $ + jsonData >>= Payment.editOwn + + delete "/payment" $ do + paymentId <- param "id" + Payment.deleteOwn paymentId + + post "/income" $ + jsonData >>= Income.create + + put "/income" $ + jsonData >>= Income.editOwn + + delete "/income" $ do + incomeId <- param "id" + Income.deleteOwn incomeId + + post "/category" $ + jsonData >>= Category.create + + put "/category" $ + jsonData >>= Category.edit + + delete "/category" $ do + categoryId <- 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/MimeMail.hs b/server/src/MimeMail.hs new file mode 100644 index 0000000..0faaf98 --- /dev/null +++ b/server/src/MimeMail.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MimeMail + ( -- * Datatypes + Boundary (..) + , Mail (..) + , emptyMail + , Address (..) + , Alternatives + , Part (..) + , Encoding (..) + , Headers + -- * Render a message + , renderMail + , renderMail' + -- * Sending messages + , sendmail + , sendmailCustom + , sendmailCustomCaptureOutput + , renderSendMail + , renderSendMailCustom + -- * High-level 'Mail' creation + , simpleMail + , simpleMail' + , simpleMailInMemory + -- * Utilities + , addPart + , addAttachment + , addAttachmentCid + , addAttachments + , addAttachmentBS + , addAttachmentBSCid + , addAttachmentsBS + , renderAddress + , htmlPart + , plainPart + , randomString + , quotedPrintable + ) where + +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder.Char.Utf8 +import Blaze.ByteString.Builder +import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) +import Data.Monoid +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import System.FilePath (takeFileName) +import qualified Data.ByteString.Base64 as Base64 +import Control.Monad ((<=<), foldM, void) +import Control.Exception (throwIO, ErrorCall (ErrorCall)) +import Data.List (intersperse) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.ByteString.Char8 () +import Data.Bits ((.&.), shiftR) +import Data.Char (isAscii, isControl) +import Data.Word (Word8) +import qualified Data.ByteString as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | Generates a random sequence of alphanumerics of the given length. +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | MIME boundary between parts of a message. +newtype Boundary = Boundary { unBoundary :: Text } + deriving (Eq, Show) +instance Random Boundary where + randomR = const random + random = first (Boundary . T.pack) . randomString 10 + +-- | An entire mail message. +data Mail = Mail + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] + -- | Other headers, excluding from, to, cc and bcc. + , mailHeaders :: Headers + -- | A list of different sets of alternatives. As a concrete example: + -- + -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] + -- + -- Make sure when specifying alternatives to place the most preferred + -- version last. + , mailParts :: [Alternatives] + } + deriving Show + +-- | A mail message with the provided 'from' address and no other +-- fields filled in. +emptyMail :: Address -> Mail +emptyMail from = Mail + { mailFrom = from + , mailTo = [] + , mailCc = [] + , mailBcc = [] + , mailHeaders = [] + , mailParts = [] + } + +data Address = Address + { addressName :: Maybe Text + , addressEmail :: Text + } + deriving (Eq, Show) + +-- | How to encode a single part. You should use 'Base64' for binary data. +data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary + deriving (Eq, Show) + +-- | Multiple alternative representations of the same data. For example, you +-- could provide a plain-text and HTML version of a message. +type Alternatives = [Part] + +-- | A single part of a multipart message. +data Part = Part + { partType :: Text -- ^ content type + , partEncoding :: Encoding + -- | The filename for this part, if it is to be sent with an attachemnt + -- disposition. + , partFilename :: Maybe Text + , partHeaders :: Headers + , partContent :: L.ByteString + } + deriving (Eq, Show) + +type Headers = [(S.ByteString, Text)] +type Pair = (Headers, Builder) + +partToPair :: Part -> Pair +partToPair (Part contentType encoding disposition headers content) = + (headers', builder) + where + headers' = + ((:) ("Content-Type", contentType)) + $ (case encoding of + None -> id + Base64 -> (:) ("Content-Transfer-Encoding", "base64") + QuotedPrintableText -> + (:) ("Content-Transfer-Encoding", "quoted-printable") + QuotedPrintableBinary -> + (:) ("Content-Transfer-Encoding", "quoted-printable")) + $ (case disposition of + Nothing -> id + Just fn -> + (:) ("Content-Disposition", "attachment; filename=" + `T.append` fn)) + $ headers + builder = + case encoding of + None -> fromWriteList writeByteString $ L.toChunks content + Base64 -> base64 content + QuotedPrintableText -> quotedPrintable True content + QuotedPrintableBinary -> quotedPrintable False content + +showPairs :: RandomGen g + => Text -- ^ multipart type, eg mixed, alternative + -> [Pair] + -> g + -> (Pair, g) +showPairs _ [] _ = error "renderParts called with null parts" +showPairs _ [pair] gen = (pair, gen) +showPairs mtype parts gen = + ((headers, builder), gen') + where + (Boundary b, gen') = random gen + headers = + [ ("Content-Type", T.concat + [ "multipart/" + , mtype + , "; boundary=\"" + , b + , "\"" + ]) + ] + builder = mconcat + [ mconcat $ intersperse (fromByteString "\n") + $ map (showBoundPart $ Boundary b) parts + , showBoundEnd $ Boundary b + ] + +-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. +renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) +renderMail g0 (Mail from to cc bcc headers parts) = + (toLazyByteString builder, g'') + where + addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] + pairs = map (map partToPair) parts + (pairs', g') = helper g0 $ map (showPairs "alternative") pairs + helper :: g -> [g -> (x, g)] -> ([x], g) + helper g [] = ([], g) + helper g (x:xs) = + let (b, g_) = x g + (bs, g__) = helper g_ xs + in (b : bs, g__) + ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' + builder = mconcat + [ mconcat addressHeaders + , mconcat $ map showHeader headers + , showHeader ("MIME-Version", "1.0") + , mconcat $ map showHeader finalHeaders + , fromByteString "\n" + , finalBuilder + ] + +-- | Format an E-Mail address according to the name-addr form (see: RFC5322 +-- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') +-- This can be handy for adding custom headers that require such format. +-- +-- @since 0.4.11 +renderAddress :: Address -> Text +renderAddress address = + TE.decodeUtf8 $ toByteString $ showAddress address + +-- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) +sanitizeFieldName :: S.ByteString -> S.ByteString +sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) + +showHeader :: (S.ByteString, Text) -> Builder +showHeader (k, v) = mconcat + [ fromByteString (sanitizeFieldName k) + , fromByteString ": " + , encodeIfNeeded (sanitizeHeader v) + , fromByteString "\n" + ] + +showAddressHeader :: (S.ByteString, [Address]) -> Builder +showAddressHeader (k, as) = + if null as + then mempty + else mconcat + [ fromByteString k + , fromByteString ": " + , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) + , fromByteString "\n" + ] + +-- | +-- +-- Since 0.4.3 +showAddress :: Address -> Builder +showAddress a = mconcat + [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) + , fromByteString "<" + , fromText (sanitizeHeader $ addressEmail a) + , fromByteString ">" + ] + +-- Filter out control characters to prevent CRLF injection. +sanitizeHeader :: Text -> Text +sanitizeHeader = T.filter (not . isControl) + +showBoundPart :: Boundary -> (Headers, Builder) -> Builder +showBoundPart (Boundary b) (headers, content) = mconcat + [ fromByteString "--" + , fromText b + , fromByteString "\n" + , mconcat $ map showHeader headers + , fromByteString "\n" + , content + ] + +showBoundEnd :: Boundary -> Builder +showBoundEnd (Boundary b) = mconcat + [ fromByteString "\n--" + , fromText b + , fromByteString "--" + ] + +-- | Like 'renderMail', but generates a random boundary. +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + g <- getStdGen + let (lbs, g') = renderMail g m + setStdGen g' + return lbs + +-- | Send a fully-formed email message via the default sendmail +-- executable with default options. +sendmail :: L.ByteString -> IO () +sendmail = sendmailCustom sendmailPath ["-t"] + +sendmailPath :: String +sendmailPath = "sendmail" + +-- | Render an email message and send via the default sendmail +-- executable with default options. +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' + +-- | Send a fully-formed email message via the specified sendmail +-- executable with specified options. +sendmailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> L.ByteString -- ^ mail message as lazy bytestring + -> IO () +sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs + +-- | Like 'sendmailCustom', but also returns sendmail's output to stderr and +-- stdout as strict ByteStrings. +-- +-- Since 0.4.9 +sendmailCustomCaptureOutput :: FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs + +sendmailCustomAux :: Bool + -> FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomAux captureOut sm opts lbs = do + let baseOpts = (proc sm opts) { std_in = CreatePipe } + pOpts = if captureOut + then baseOpts { std_out = CreatePipe + , std_err = CreatePipe + } + else baseOpts + (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts + L.hPut hin lbs + hClose hin + errMVar <- newEmptyMVar + outMVar <- newEmptyMVar + case (mHOut, mHErr) of + (Nothing, Nothing) -> return () + (Just hOut, Just hErr) -> do + void . forkIO $ S.hGetContents hOut >>= putMVar outMVar + void . forkIO $ S.hGetContents hErr >>= putMVar errMVar + _ -> error "error in sendmailCustomAux: missing a handle" + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> if captureOut + then do + errOutput <- takeMVar errMVar + outOutput <- takeMVar outMVar + return (outOutput, errOutput) + else return (S.empty, S.empty) + _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) + +-- | Render an email message and send via the specified sendmail +-- executable with specified options. +renderSendMailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> Mail -- ^ mail to render and send + -> IO () +renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' + +-- FIXME usage of FilePath below can lead to issues with filename encoding + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some file attachments. +-- +-- Note that we use lazy IO for reading in the attachment contents. +simpleMail :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, FilePath)] -- ^ content type and path of attachments + -> IO Mail +simpleMail to from subject plainBody htmlBody attachments = + addAttachments attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with only plain-text body. +simpleMail' :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ body + -> Mail +simpleMail' to from subject body = addPart [plainPart body] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some 'ByteString' attachments. +-- +-- Since 0.4.7 +simpleMailInMemory :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments + -> Mail +simpleMailInMemory to from subject plainBody htmlBody attachments = + addAttachmentsBS attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +mailFromToSubject :: Address -- ^ from + -> Address -- ^ to + -> Text -- ^ subject + -> Mail +mailFromToSubject from to subject = + (emptyMail from) { mailTo = [to] + , mailHeaders = [("Subject", subject)] + } + +-- | Add an 'Alternative' to the 'Mail's parts. +-- +-- To e.g. add a plain text body use +-- > addPart [plainPart body] (emptyMail from) +addPart :: Alternatives -> Mail -> Mail +addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } + +-- | Construct a UTF-8-encoded plain-text 'Part'. +plainPart :: LT.Text -> Part +plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/plain; charset=utf-8" + +-- | Construct a UTF-8-encoded html 'Part'. +htmlPart :: LT.Text -> Part +htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/html; charset=utf-8" + +-- | Add an attachment from a file and construct a 'Part'. +addAttachment :: Text -> FilePath -> Mail -> IO Mail +addAttachment ct fn mail = do + part <- getAttachmentPart ct fn + return $ addPart [part] mail + +-- | Add an attachment from a file and construct a 'Part' +-- with the specified content id in the Content-ID header. +-- +-- @since 0.4.12 +addAttachmentCid :: Text -- ^ content type + -> FilePath -- ^ file name + -> Text -- ^ content ID + -> Mail + -> IO Mail +addAttachmentCid ct fn cid mail = + getAttachmentPart ct fn >>= (return.addToMail.addHeader) + where + addToMail part = addPart [part] mail + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail +addAttachments xs mail = foldM fun mail xs + where fun m (c, f) = addAttachment c f m + +-- | Add an attachment from a 'ByteString' and construct a 'Part'. +-- +-- Since 0.4.7 +addAttachmentBS :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Mail -> Mail +addAttachmentBS ct fn content mail = + let part = getAttachmentPartBS ct fn content + in addPart [part] mail + +-- | @since 0.4.12 +addAttachmentBSCid :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Text -- ^ content ID + -> Mail -> Mail +addAttachmentBSCid ct fn content cid mail = + let part = addHeader $ getAttachmentPartBS ct fn content + in addPart [part] mail + where + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +-- | +-- Since 0.4.7 +addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail +addAttachmentsBS xs mail = foldl fun mail xs + where fun m (ct, fn, content) = addAttachmentBS ct fn content m + +getAttachmentPartBS :: Text + -> Text + -> L.ByteString + -> Part +getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content + +getAttachmentPart :: Text -> FilePath -> IO Part +getAttachmentPart ct fn = do + content <- L.readFile fn + return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content + +data QP = QPPlain S.ByteString + | QPNewline + | QPTab + | QPSpace + | QPEscape S.ByteString + +data QPC = QPCCR + | QPCLF + | QPCSpace + | QPCTab + | QPCPlain + | QPCEscape + deriving Eq + +toQP :: Bool -- ^ text? + -> L.ByteString + -> [QP] +toQP isText = + go + where + go lbs = + case L.uncons lbs of + Nothing -> [] + Just (c, rest) -> + case toQPC c of + QPCCR -> go rest + QPCLF -> QPNewline : go rest + QPCSpace -> QPSpace : go rest + QPCTab -> QPTab : go rest + QPCPlain -> + let (x, y) = L.span ((== QPCPlain) . toQPC) lbs + in QPPlain (toStrict x) : go y + QPCEscape -> + let (x, y) = L.span ((== QPCEscape) . toQPC) lbs + in QPEscape (toStrict x) : go y + + toStrict = S.concat . L.toChunks + + toQPC :: Word8 -> QPC + toQPC 13 | isText = QPCCR + toQPC 10 | isText = QPCLF + toQPC 9 = QPCTab + toQPC 0x20 = QPCSpace + toQPC 46 = QPCEscape + toQPC 61 = QPCEscape + toQPC w + | 33 <= w && w <= 126 = QPCPlain + | otherwise = QPCEscape + +buildQPs :: [QP] -> Builder +buildQPs = + go (0 :: Int) + where + go _ [] = mempty + go currLine (qp:qps) = + case qp of + QPNewline -> copyByteString "\r\n" `mappend` go 0 qps + QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) + QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) + QPPlain bs -> + let toTake = 75 - currLine + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPPlain y : qps + in helper (S.length x) (copyByteString x) (S.null y) rest + QPEscape bs -> + let toTake = (75 - currLine) `div` 3 + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPEscape y : qps + in if toTake == 0 + then copyByteString "=\r\n" `mappend` go 0 (qp:qps) + else helper (S.length x * 3) (escape x) (S.null y) rest + where + escape = + S.foldl' add mempty + where + add builder w = + builder `mappend` escaped + where + escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + + helper added builder noMore rest = + builder' `mappend` go newLine rest + where + (newLine, builder') + | not noMore || (added + currLine) >= 75 = + (0, builder `mappend` copyByteString "=\r\n") + | otherwise = (added + currLine, builder) + + wsHelper enc raw + | null qps = + if currLine <= 73 + then enc + else copyByteString "\r\n=" `mappend` enc + | otherwise = helper 1 raw (currLine < 76) qps + +-- | The first parameter denotes whether the input should be treated as text. +-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If +-- binary, then CRs and LFs will be escaped. +quotedPrintable :: Bool -> L.ByteString -> Builder +quotedPrintable isText = buildQPs . toQP isText + +hex :: Word8 -> Builder +hex x + | x < 10 = fromWord8 $ x + 48 + | otherwise = fromWord8 $ x + 55 + +encodeIfNeeded :: Text -> Builder +encodeIfNeeded t = + if needsEncodedWord t + then encodedWord t + else fromText t + +needsEncodedWord :: Text -> Bool +needsEncodedWord = not . T.all isAscii + +encodedWord :: Text -> Builder +encodedWord t = mconcat + [ fromByteString "=?utf-8?Q?" + , S.foldl' go mempty $ TE.encodeUtf8 t + , fromByteString "?=" + ] + where + go front w = front `mappend` go' w + go' 32 = fromWord8 95 -- space + go' 95 = go'' 95 -- _ + go' 63 = go'' 63 -- ? + go' 61 = go'' 61 -- = + + -- The special characters from RFC 2822. Not all of these always give + -- problems, but at least @[];"<>, gave problems with some mail servers + -- when used in the 'name' part of an address. + go' 34 = go'' 34 -- " + go' 40 = go'' 40 -- ( + go' 41 = go'' 41 -- ) + go' 44 = go'' 44 -- , + go' 46 = go'' 46 -- . + go' 58 = go'' 58 -- ; + go' 59 = go'' 59 -- ; + go' 60 = go'' 60 -- < + go' 62 = go'' 62 -- > + go' 64 = go'' 64 -- @ + go' 91 = go'' 91 -- [ + go' 92 = go'' 92 -- \ + go' 93 = go'' 93 -- ] + go' w + | 33 <= w && w <= 126 = fromWord8 w + | otherwise = go'' w + go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + +-- 57 bytes, when base64-encoded, becomes 76 characters. +-- Perform the encoding 57-bytes at a time, and then append a newline. +base64 :: L.ByteString -> Builder +base64 lbs + | L.null lbs = mempty + | otherwise = fromByteString x64 `mappend` + fromByteString "\r\n" `mappend` + base64 y + where + (x', y) = L.splitAt 57 lbs + x = S.concat $ L.toChunks x' + x64 = Base64.encode x diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs new file mode 100644 index 0000000..6b7a488 --- /dev/null +++ b/server/src/Model/Category.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Category + ( list + , create + , edit + , delete + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Category(..), CategoryId) + +import Model.Query (Query(Query)) + +instance FromRow Category where + fromRow = Category <$> + 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" + ) + +create :: Text -> Text -> Query CategoryId +create categoryName categoryColor = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" + (categoryName, categoryColor, now) + SQLite.lastInsertRowId conn + ) + +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]) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" + (now, categoryName, categoryColor, categoryId) + return True + else + return False + ) + +delete :: CategoryId -> Query Bool +delete categoryId = + Query (\conn -> do + mbCategory <- listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + return True + else + return False + ) diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs new file mode 100644 index 0000000..b334a40 --- /dev/null +++ b/server/src/Model/Frequency.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Frequency () where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +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"] + +instance ToField Frequency where + toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs new file mode 100644 index 0000000..bbe7657 --- /dev/null +++ b/server/src/Model/Income.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Income + ( list + , create + , editOwn + , deleteOwn + , modifiedDuring + ) where + +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Income(..), IncomeId, User(..), UserId) + +import Model.Query (Query(Query)) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) + +instance Resource Income where + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt + +instance FromRow Income where + fromRow = Income <$> + 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") + +create :: UserId -> Day -> Int -> Query IncomeId +create incomeUserId incomeDate incomeAmount = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" + (incomeUserId, incomeDate, incomeAmount, now) + SQLite.lastInsertRowId conn + ) + +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) + case mbIncome of + Just income -> + if _income_userId income == incomeUserId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" + (now, incomeDate, incomeAmount, incomeId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: User -> IncomeId -> Query Bool +deleteOwn user incomeId = + Query (\conn -> do + mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == _user_id user + then do + now <- getCurrentTime + SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) + return True + else + return False + 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 new file mode 100644 index 0000000..8c6a961 --- /dev/null +++ b/server/src/Model/Init.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.Init + ( getInit + ) where + +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf +import Model.Query (Query) +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 qualified Model.User as User + +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs new file mode 100644 index 0000000..9a4db73 --- /dev/null +++ b/server/src/Model/Mail.hs @@ -0,0 +1,12 @@ +module Model.Mail + ( Mail(..) + ) where + +import Data.Text (Text) + +data Mail = Mail + { from :: Text + , to :: [Text] + , subject :: Text + , plainBody :: Text + } deriving (Eq, Show) diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/server/src/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs new file mode 100644 index 0000000..14efe77 --- /dev/null +++ b/server/src/Model/Payment.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Payment + ( Payment(..) + , find + , list + , listMonthly + , 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 (Only(Only), FromRow(fromRow), ToRow) +import Database.SQLite.Simple.ToField (ToField(toField)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Frequency(..), Payment(..), PaymentId, UserId) + +import Model.Frequency () +import Model.Query (Query(Query)) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) + +instance Resource Payment where + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt + +instance FromRow Payment where + fromRow = Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +instance ToRow Payment where + toRow p = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_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) + ) + +list :: Query [Payment] +list = + Query (\conn -> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + ) + +listMonthly :: Query [Payment] +listMonthly = + 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) + ) + +create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId +create userId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + SQLite.lastInsertRowId conn + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + payments + ) + +editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) + (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: UserId -> PaymentId -> Query Bool +deleteOwn userId paymentId = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE payment SET deleted_at = ? WHERE id = ?" + (now, paymentId) + return True + else + return False + 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/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs new file mode 100644 index 0000000..6e1d304 --- /dev/null +++ b/server/src/Model/PaymentCategory.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.PaymentCategory + ( list + , listByCategory + , save + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Data.Text as T +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T + +import Model.Query (Query(Query)) + +instance FromRow PaymentCategory where + fromRow = PaymentCategory <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [PaymentCategory] +list = Query (\conn -> 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) + ) + +save :: Text -> CategoryId -> Query () +save newName categoryId = + Query (\conn -> do + now <- getCurrentTime + mbPaymentCategory <- listToMaybe <$> + (SQLite.query + conn + "SELECT * FROM payment_category WHERE name = ?" + (Only (formatPaymentName newName)) :: IO [PaymentCategory]) + if isJust mbPaymentCategory + then + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formatPaymentName newName) + else do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formatPaymentName newName, categoryId, now) + ) + where + formatPaymentName :: Text -> Text + formatPaymentName = T.unaccent . T.toLower diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs new file mode 100644 index 0000000..d15fb5f --- /dev/null +++ b/server/src/Model/Query.hs @@ -0,0 +1,32 @@ +module Model.Query + ( Query(..) + , run + ) where + +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) +import qualified Database.SQLite.Simple as SQLite + +data Query a = Query (Connection -> IO a) + +instance Functor Query where + fmap f (Query call) = Query (fmap f . call) + +instance Applicative Query where + pure x = Query (const $ return x) + (Query callF) <*> (Query callX) = Query (\conn -> do + x <- callX conn + f <- callF conn + return (f x)) + +instance Monad Query where + (Query callX) >>= f = Query (\conn -> do + x <- callX conn + case f x of Query callY -> callY conn) + +run :: Query a -> IO a +run (Query call) = do + conn <- SQLite.open "database" + result <- call conn + _ <- SQLite.close conn + return result diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs new file mode 100644 index 0000000..c5182f0 --- /dev/null +++ b/server/src/Model/SignIn.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.SignIn + ( SignIn(..) + , createSignInToken + , getSignIn + , signInTokenToUsed + , isLastTokenValid + ) where + +import Data.Int (Int64) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Database.SQLite.Simple as SQLite + +import Model.Query (Query(Query)) +import Model.UUID (generateUUID) + +type SignInId = Int64 + +data SignIn = SignIn + { id :: SignInId + , token :: Text + , creation :: UTCTime + , email :: Text + , isUsed :: Bool + } deriving Show + +instance FromRow SignIn where + fromRow = SignIn <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +createSignInToken :: Text -> Query Text +createSignInToken signInEmail = + Query (\conn -> do + now <- getCurrentTime + signInToken <- generateUUID + SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) + return signInToken + ) + +getSignIn :: Text -> Query (Maybe SignIn) +getSignIn signInToken = + Query (\conn -> do + listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) + ) + +signInTokenToUsed :: SignInId -> Query () +signInTokenToUsed tokenId = + Query (\conn -> + SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) + ) + +isLastTokenValid :: SignIn -> Query Bool +isLastTokenValid signIn = + Query (\conn -> do + [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) + return . maybe False (== (token signIn)) $ lastToken + ) diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs new file mode 100644 index 0000000..6cb7ce0 --- /dev/null +++ b/server/src/Model/UUID.hs @@ -0,0 +1,10 @@ +module Model.UUID + ( generateUUID + ) where + +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) +import Data.Text (Text, pack) + +generateUUID :: IO Text +generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs new file mode 100644 index 0000000..e14fcef --- /dev/null +++ b/server/src/Model/User.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# 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 (Only(Only), FromRow(fromRow)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (UserId, User(..)) + +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/Resource.hs b/server/src/Resource.hs new file mode 100644 index 0000000..f52bbfa --- /dev/null +++ b/server/src/Resource.hs @@ -0,0 +1,54 @@ +module Resource + ( Resource + , resourceCreatedAt + , resourceEditedAt + , resourceDeletedAt + , Status(..) + , statuses + , groupByStatus + , statusDuring + ) where + +import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Time.Clock (UTCTime) + +class Resource a where + resourceCreatedAt :: a -> UTCTime + resourceEditedAt :: a -> Maybe UTCTime + resourceDeletedAt :: a -> Maybe UTCTime + +data Status = + Created + | Edited + | Deleted + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +statuses :: [Status] +statuses = [minBound..] + +groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] +groupByStatus start end resources = + foldl + (\m resource -> + case statusDuring start end resource of + Just status -> M.insertWith (++) status [resource] m + Nothing -> m + ) + M.empty + resources + +statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status +statusDuring start end resource + | created && not deleted = Just Created + | not created && edited && not deleted = Just Edited + | not created && deleted = Just Deleted + | otherwise = Nothing + where + created = belongs (resourceCreatedAt resource) start end + edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) + deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) + +belongs :: UTCTime -> UTCTime -> UTCTime -> Bool +belongs time start end = time >= start && time < end diff --git a/server/src/Secure.hs b/server/src/Secure.hs new file mode 100644 index 0000000..f427304 --- /dev/null +++ b/server/src/Secure.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Secure + ( loggedAction + , getUserFromToken + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + +import Model.Query (Query) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User + +loggedAction :: (User -> ActionM ()) -> ActionM () +loggedAction action = do + maybeToken <- LoginSession.get + case maybeToken of + Just token -> do + maybeUser <- liftIO . Query.run . getUserFromToken $ token + case maybeUser of + Just user -> + action user + Nothing -> do + status forbidden403 + html . fromStrict . Message.get $ Key.Secure_Unauthorized + Nothing -> do + status forbidden403 + html . fromStrict . Message.get $ Key.Secure_Forbidden + +getUserFromToken :: Text -> Query (Maybe User) +getUserFromToken token = do + mbSignIn <- SignIn.getSignIn token + case mbSignIn of + Just signIn -> + User.get (SignIn.email signIn) + Nothing -> + return Nothing diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs new file mode 100644 index 0000000..f7ba3fd --- /dev/null +++ b/server/src/SendMail.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SendMail + ( sendMail + ) where + +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) + +import Data.Text (Text) +import Data.Text.Lazy.Builder (toLazyText, fromText) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified MimeMail as M + +import Model.Mail (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 + +getMimeMail :: Mail -> M.Mail +getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = + let fromMail = M.emptyMail (address mailFrom) + in fromMail + { M.mailTo = map address mailTo + , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] + , M.mailHeaders = [("Subject", mailSubject)] + } + +address :: Text -> M.Address +address addressEmail = + M.Address + { M.addressName = Nothing + , M.addressEmail = addressEmail + } + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs new file mode 100644 index 0000000..97457c7 --- /dev/null +++ b/server/src/Utils/Time.hs @@ -0,0 +1,25 @@ +module Utils.Time + ( belongToCurrentMonth + , belongToCurrentWeek + , timeToDay + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/Validation.hs b/server/src/Validation.hs new file mode 100644 index 0000000..1f332c9 --- /dev/null +++ b/server/src/Validation.hs @@ -0,0 +1,23 @@ +module Validation + ( nonEmpty + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +nonEmpty :: Text -> Maybe Text +nonEmpty str = + if T.null str + then Nothing + else Just str + +number :: (Int -> Bool) -> Text -> Maybe Int +number numberForm str = + case reads (T.unpack str) :: [(Int, String)] of + (num, _) : _ -> + if numberForm num + then Just num + else Nothing + _ -> + Nothing diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs new file mode 100644 index 0000000..1daca1e --- /dev/null +++ b/server/src/View/Mail/SignIn.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.SignIn + ( mail + ) where + +import Data.Text (Text) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User(..)) + +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M + +mail :: Conf -> User -> Text -> [Text] -> M.Mail +mail conf user url to = + M.Mail + { M.from = Conf.noReplyMail conf + , M.to = to + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) + } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs new file mode 100644 index 0000000..b5f2b67 --- /dev/null +++ b/server/src/View/Mail/WeeklyReport.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.WeeklyReport + ( mail + ) where + +import Data.List (sortOn) +import Data.Map (Map) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import qualified Data.Map as M +import qualified Data.Text as T + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model as CM +import qualified Common.View.Format as Format + +import Model.Mail (Mail(Mail)) +import Model.Payment () +import qualified Model.Income () +import qualified Model.Mail as M +import Resource (Status(..), groupByStatus, statuses) +import Conf (Conf) +import qualified Conf as Conf + +mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail +mail conf users payments incomes start end = + Mail + { M.from = Conf.noReplyMail conf + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] + , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) + } + +body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +body conf users paymentsByStatus incomesByStatus = + if M.null paymentsByStatus && M.null incomesByStatus + then + Message.get Key.WeeklyReport_Empty + else + T.intercalate "\n" . catMaybes . concat $ + [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses + , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses + ] + +paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text +paymentSection status conf users payments = + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments + +payedFor :: Status -> Conf -> [User] -> Payment -> Text +payedFor status conf users payment = + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment + +incomeSection :: Status -> Conf -> [User] -> [Income] -> Text +incomeSection status conf users incomes = + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes + +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text +isPayedFrom status conf users income = + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income + +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap _user_name . CM.findUser userId + +section :: Text -> [Text] -> Text +section title items = + T.concat + [ title + , "\n\n" + , T.unlines . map (" - " <>) $ items + ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs new file mode 100644 index 0000000..6bf9527 --- /dev/null +++ b/server/src/View/Page.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Page + ( page + ) where + +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json + +import Text.Blaze.Html +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult) + +import Design.Global (globalDesign) + +page :: InitResult -> Text +page initResult = + renderHtml . docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" + H.title (toHtml $ Message.get Key.App_Title) + 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" + H.style $ toHtml globalDesign + +jsonScript :: Json.ToJSON a => Text -> a -> Html +jsonScript scriptId json = + script + ! A.id (toValue scriptId) + ! type_ "application/json" + $ toHtml . decodeUtf8 . encode $ json -- cgit v1.2.3 From 30f786e277b4ece6a09311de364082691f261ca3 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 10 Nov 2017 01:23:49 +0100 Subject: Minify javascript in dist mode, compress served files with gzip --- server/src/Main.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'server/src') diff --git a/server/src/Main.hs b/server/src/Main.hs index db73474..96c13ee 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -3,8 +3,10 @@ import Control.Applicative (liftA3) import Control.Monad.IO.Class (liftIO) -import Network.Wai.Middleware.Static 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 qualified Conf @@ -26,6 +28,7 @@ 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" get "/exceedingPayer" $ do -- cgit v1.2.3 From 213cf7ede058b781fc957de2cd9f6a5988c08004 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 12 Nov 2017 22:58:23 +0100 Subject: Add mocked pages --- server/src/Design/Color.hs | 5 +++++ server/src/Design/View/Payment/Pages.hs | 6 ++++-- server/src/Design/View/Payment/Table.hs | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs index 06c468e..9a5797f 100644 --- a/server/src/Design/Color.hs +++ b/server/src/Design/Color.hs @@ -1,6 +1,8 @@ module Design.Color where +import Clay import qualified Clay.Color as C +import Data.Text (Text) -- http://chir.ag/projects/name-that-color/#969696 @@ -33,3 +35,6 @@ silver = C.rgb 200 200 200 dustyGray :: C.Color dustyGray = C.rgb 150 150 150 + +toString :: C.Color -> Text +toString = plain . unValue . value diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index ade81a8..5fc13f0 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -13,8 +13,8 @@ import qualified Design.Media as Media design :: Css design = do - textAlign (alignSide sideCenter) - Helper.clearFix + display flex + justifyContent center Media.desktop $ do padding (px 40) (px 30) (px 30) (px 30) @@ -26,6 +26,8 @@ design = do padding (px 20) (px 0) (px 20) (px 0) lineHeight (px 40) + svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) + ".page" ? do display inlineBlock fontWeight bold diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index a866b40..f8326e4 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -38,5 +38,5 @@ design = do marginBottom (em 0.5) ".button" & svg ? do - "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + "path" ? ("fill" -: Color.toString Color.chestnutRose) width (px 18) -- cgit v1.2.3 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- server/src/Conf.hs | 20 +++++----- server/src/Controller/Category.hs | 23 +++++------ server/src/Controller/Income.hs | 21 +++++----- server/src/Controller/Index.hs | 36 ++++++++--------- server/src/Controller/Payment.hs | 22 ++++++----- server/src/Controller/SignIn.hs | 32 +++++++-------- server/src/Cookie.hs | 22 +++++------ server/src/Design/Color.hs | 4 +- server/src/Design/Constants.hs | 2 +- server/src/Design/Dialog.hs | 4 +- server/src/Design/Errors.hs | 4 +- server/src/Design/Form.hs | 6 +-- server/src/Design/Global.hs | 20 +++++----- server/src/Design/Helper.hs | 8 ++-- server/src/Design/Media.hs | 6 +-- server/src/Design/Tooltip.hs | 4 +- server/src/Design/View/Header.hs | 8 ++-- server/src/Design/View/Payment.hs | 6 +-- server/src/Design/View/Payment/Header.hs | 12 +++--- server/src/Design/View/Payment/Pages.hs | 8 ++-- server/src/Design/View/Payment/Table.hs | 2 +- server/src/Design/View/SignIn.hs | 8 ++-- server/src/Design/View/Stat.hs | 2 +- server/src/Design/View/Table.hs | 6 +-- server/src/Design/Views.hs | 20 +++++----- server/src/Job/Daemon.hs | 25 ++++++------ server/src/Job/Frequency.hs | 2 +- server/src/Job/Kind.hs | 13 +++--- server/src/Job/Model.hs | 18 ++++----- server/src/Job/MonthlyPayment.hs | 10 ++--- server/src/Job/WeeklyReport.hs | 12 +++--- server/src/Json.hs | 10 ++--- server/src/LoginSession.hs | 15 +++---- server/src/Main.hs | 38 +++++++++--------- server/src/MimeMail.hs | 68 ++++++++++++++++---------------- server/src/Model/Category.hs | 16 ++++---- server/src/Model/Frequency.hs | 21 +++++----- server/src/Model/Income.hs | 18 +++++---- server/src/Model/Init.hs | 14 +++---- server/src/Model/Mail.hs | 8 ++-- server/src/Model/Payer.hs | 31 ++++++++------- server/src/Model/Payment.hs | 34 +++++++++------- server/src/Model/PaymentCategory.hs | 18 ++++----- server/src/Model/Query.hs | 4 +- server/src/Model/SignIn.hs | 24 +++++------ server/src/Model/UUID.hs | 6 +-- server/src/Model/User.hs | 16 ++++---- server/src/Resource.hs | 10 ++--- server/src/Secure.hs | 24 +++++------ server/src/SendMail.hs | 18 ++++----- server/src/Utils/Time.hs | 8 ++-- server/src/Validation.hs | 2 +- server/src/View/Mail/SignIn.hs | 12 +++--- server/src/View/Mail/WeeklyReport.hs | 41 +++++++++---------- server/src/View/Page.hs | 28 ++++++------- 55 files changed, 444 insertions(+), 426 deletions(-) (limited to 'server/src') diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 26c5c28..299f071 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -5,20 +5,20 @@ module Conf , Conf(..) ) where -import Data.Text (Text) -import qualified Data.Text as T import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) -import Common.Model (Currency(..)) +import Common.Model (Currency (..)) data Conf = Conf - { hostname :: Text - , port :: Int + { hostname :: Text + , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: Bool + , currency :: Currency + , noReplyMail :: Text + , https :: Bool } deriving Show get :: FilePath -> IO Conf @@ -36,4 +36,4 @@ get path = do ) case conf of Left msg -> error (T.unpack msg) - Right c -> return c + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index d6ed2f2..a646496 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -6,19 +6,20 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -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 qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) -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.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure create :: CreateCategory -> ActionM () diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 148b713..c42f6a7 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -6,18 +6,19 @@ module Controller.Income , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome (..), EditIncome (..), + IncomeId, User (..)) -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query import qualified Secure create :: CreateIncome -> ActionM () diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 8473c5c..bf4859d 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -3,26 +3,26 @@ module Controller.Index , signOut ) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult (..), User (..)) -import Conf (Conf(..)) -import Model.Init (getInit) +import Conf (Conf (..)) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) +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 View.Page (page) get :: Conf -> Maybe Text -> ActionM () get conf mbToken = do @@ -70,7 +70,7 @@ validateSignIn conf textToken = do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index dc10311..e4104eb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -7,16 +7,18 @@ module Controller.Payment , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty + +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 Secure list :: ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 0086fa5..5552781 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -4,25 +4,25 @@ module Controller.SignIn ( signIn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty +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 qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn (..)) -import Conf (Conf) +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 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 +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn signIn :: Conf -> SignIn -> ActionM () signIn conf (SignIn email) = @@ -41,7 +41,7 @@ signIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail Nothing -> textKey badRequest400 Key.Secure_Unauthorized else textKey badRequest400 Key.SignIn_EmailInvalid where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs index 96d45da..511dd42 100644 --- a/server/src/Cookie.hs +++ b/server/src/Cookie.hs @@ -9,25 +9,25 @@ module Cookie , deleteCookie ) where -import Control.Monad ( liftM ) +import Control.Monad (liftM) -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL -import Conf (Conf) +import Conf (Conf) import qualified Conf -import qualified Data.Map as Map +import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as BSL -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Blaze.ByteString.Builder ( toLazyByteString ) +import Blaze.ByteString.Builder (toLazyByteString) -import Web.Scotty.Trans -import Web.Cookie +import Web.Cookie +import Web.Scotty.Trans makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie makeSimpleCookie conf name value = diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs index 9a5797f..e7f5aec 100644 --- a/server/src/Design/Color.hs +++ b/server/src/Design/Color.hs @@ -1,8 +1,8 @@ module Design.Color where -import Clay +import Clay import qualified Clay.Color as C -import Data.Text (Text) +import Data.Text (Text) -- http://chir.ag/projects/name-that-color/#969696 diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs index 4e2b8cc..a3123d9 100644 --- a/server/src/Design/Constants.hs +++ b/server/src/Design/Constants.hs @@ -1,6 +1,6 @@ module Design.Constants where -import Clay +import Clay iconFontSize :: Size LengthUnit iconFontSize = px 32 diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs index 4678633..6759606 100644 --- a/server/src/Design/Dialog.hs +++ b/server/src/Design/Dialog.hs @@ -4,9 +4,9 @@ module Design.Dialog ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay design :: Css design = do diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs index 57aaeee..2c6c16b 100644 --- a/server/src/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -4,9 +4,9 @@ module Design.Errors ( design ) where -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index ebb8ac8..a4a1de0 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -4,11 +4,11 @@ module Design.Form ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 47ea4a9..1fe6a80 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -4,20 +4,20 @@ module Design.Global ( globalDesign ) where -import Clay +import Clay -import Data.Text.Lazy (Text) +import Data.Text.Lazy (Text) -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip +import qualified Design.Dialog as Dialog +import qualified Design.Errors as Errors +import qualified Design.Form as Form +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media globalDesign :: Text globalDesign = renderWith compact [] global diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 41528ed..0913511 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -9,12 +9,12 @@ module Design.Helper , verticalCentering ) where -import Prelude hiding (span) +import Prelude hiding (span) -import Clay hiding (button, input) +import Clay hiding (button, input) -import Design.Constants -import Design.Color as Color +import Design.Color as Color +import Design.Constants clearFix :: Css clearFix = diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs index 77220ee..19a3b8c 100644 --- a/server/src/Design/Media.hs +++ b/server/src/Design/Media.hs @@ -6,10 +6,10 @@ module Design.Media , desktop ) where -import Clay hiding (query) +import Clay hiding (query) import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media +import qualified Clay.Media as Media +import Clay.Stylesheet (Feature) mobile :: Css -> Css mobile = query [Media.maxWidth mobileTabletLimit] diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs index 1da8764..57aec33 100644 --- a/server/src/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -4,9 +4,9 @@ module Design.Tooltip ( design ) where -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 20627e6..d05f748 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -4,13 +4,13 @@ module Design.View.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color import qualified Design.Helper as Helper -import qualified Design.Media as Media +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index d3c7650..62f7061 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,11 +4,11 @@ module Design.View.Payment ( design ) where -import Clay +import Clay import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages +import qualified Design.View.Payment.Pages as Pages +import qualified Design.View.Payment.Table as Table design :: Css design = do diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index f02da8a..d87e95b 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -4,16 +4,16 @@ module Design.View.Payment.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Constants +import Design.Constants -import qualified Design.Helper as Helper -import qualified Design.Color as Color +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index 5fc13f0..f6660a1 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -4,12 +4,12 @@ module Design.View.Payment.Pages ( design ) where -import Clay +import Clay -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index f8326e4..243d7f4 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -4,7 +4,7 @@ module Design.View.Payment.Table ( design ) where -import Clay +import Clay import qualified Design.Color as Color import qualified Design.Media as Media diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 214e663..2b1252f 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -4,12 +4,12 @@ module Design.View.SignIn ( design ) where -import Clay -import Data.Monoid ((<>)) +import Clay +import Data.Monoid ((<>)) -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants +import qualified Design.Helper as Helper design :: Css design = do diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index 0a5b258..b10dd7b 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -4,7 +4,7 @@ module Design.View.Stat ( design ) where -import Clay +import Clay design :: Css design = do diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index 95abf90..fd55656 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -4,11 +4,11 @@ module Design.View.Table ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color import qualified Design.Media as Media design :: Css diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index bc6ac83..1157b68 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,18 +4,18 @@ module Design.Views ( design ) where -import Clay +import Clay -import qualified Design.View.Header as Header +import qualified Design.View.Header as Header import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 0bc6f6e..26977d1 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -2,18 +2,19 @@ module Job.Daemon ( runDaemons ) where -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Conf (Conf) +import Job.Frequency (Frequency (..), microSeconds) +import Job.Kind (Kind (..)) +import Job.Model (actualizeLastCheck, actualizeLastExecution, + getLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do @@ -29,7 +30,7 @@ runDaemon kind frequency isLastExecutionTooOld runJob = getLastExecution kind hasToRun <- case mbLastExecution of Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True + Nothing -> return True if hasToRun then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) else return () diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs index 263f6e6..c5bef42 100644 --- a/server/src/Job/Frequency.hs +++ b/server/src/Job/Frequency.hs @@ -10,4 +10,4 @@ data Frequency = microSeconds :: Frequency -> Int microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs index af5d4f8..17997f7 100644 --- a/server/src/Job/Kind.hs +++ b/server/src/Job/Kind.hs @@ -2,11 +2,12 @@ module Job.Kind ( Kind(..) ) where -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) data Kind = MonthlyPayment @@ -16,7 +17,7 @@ data Kind = instance FromField Kind where fromField field = case fieldData field of SQLText text -> Ok (read (T.unpack text) :: Kind) - _ -> Errors [error "SQLText field required for job kind"] + _ -> Errors [error "SQLText field required for job kind"] instance ToField Kind where toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index e1a3c77..b90dca0 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -7,20 +7,20 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id) -import Job.Kind -import Model.Query (Query(Query)) +import Job.Kind +import Model.Query (Query (Query)) data Job = Job - { id :: String - , kind :: Kind + { id :: String + , kind :: Kind , lastExecution :: Maybe UTCTime - , lastCheck :: Maybe UTCTime + , lastCheck :: Maybe UTCTime } deriving (Show) getLastExecution :: Kind -> Query (Maybe UTCTime) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ba24cca..8cb1c27 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,13 +2,13 @@ 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 Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import Utils.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 5737c75..74180df 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -2,13 +2,13 @@ module Job.WeeklyReport ( weeklyReport ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +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 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 SendMail import qualified View.Mail.WeeklyReport as WeeklyReport diff --git a/server/src/Json.hs b/server/src/Json.hs index cc6327a..eb5c572 100644 --- a/server/src/Json.hs +++ b/server/src/Json.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} module Json ( jsonObject , jsonId ) where -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Aeson.Types as Json +import qualified Data.Aeson.Types as Json import qualified Data.HashMap.Strict as M -import Web.Scotty +import Data.Int (Int64) +import Data.Text (Text) +import Web.Scotty jsonObject :: [(Text, Json.Value)] -> ActionM () jsonObject = json . Json.Object . M.fromList diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs index 6f6d620..beca697 100644 --- a/server/src/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -6,16 +6,17 @@ module LoginSession , delete ) where -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS +import Cookie (deleteCookie, getCookie, + setSimpleCookie) +import qualified Web.ClientSession as CS +import Web.Scotty (ActionM) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import qualified Data.Text.Encoding as TE +import Data.Text (Text) +import qualified Data.Text.Encoding as TE -import Conf (Conf) +import Conf (Conf) sessionName :: Text sessionName = "SESSION" diff --git a/server/src/Main.hs b/server/src/Main.hs index 96c13ee..5ac68db 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,27 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) +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 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 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 Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query +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 Model.Payer (getOrderedExceedingPayers) +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query +import qualified Model.User as UserM main :: IO () main = do diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs index 0faaf98..7fe98ed 100644 --- a/server/src/MimeMail.hs +++ b/server/src/MimeMail.hs @@ -38,31 +38,33 @@ module MimeMail , quotedPrintable ) where -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM, void) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii, isControl) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Control.Arrow +import Control.Concurrent (forkIO, newEmptyMVar, + putMVar, takeMVar) +import Control.Exception (ErrorCall (ErrorCall), + throwIO) +import Control.Monad (foldM, void, (<=<)) +import Data.Bits (shiftR, (.&.)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Base64 as Base64 +import Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as L +import Data.Char (isAscii, isControl) +import Data.List (intersperse) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Word (Word8) +import System.Exit +import System.FilePath (takeFileName) +import System.IO +import System.Process +import System.Random -- | Generates a random sequence of alphanumerics of the given length. randomString :: RandomGen d => Int -> d -> (String, d) @@ -88,10 +90,10 @@ instance Random Boundary where -- | An entire mail message. data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] -- | Other headers, excluding from, to, cc and bcc. , mailHeaders :: Headers -- | A list of different sets of alternatives. As a concrete example: @@ -100,7 +102,7 @@ data Mail = Mail -- -- Make sure when specifying alternatives to place the most preferred -- version last. - , mailParts :: [Alternatives] + , mailParts :: [Alternatives] } deriving Show @@ -132,13 +134,13 @@ type Alternatives = [Part] -- | A single part of a multipart message. data Part = Part - { partType :: Text -- ^ content type + { partType :: Text -- ^ content type , partEncoding :: Encoding -- | The filename for this part, if it is to be sent with an attachemnt -- disposition. , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString + , partHeaders :: Headers + , partContent :: L.ByteString } deriving (Eq, Show) diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs index 6b7a488..b972ebd 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Model/Category.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category @@ -8,16 +8,16 @@ module Model.Category , delete ) where -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Data.Maybe (isJust, 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 Prelude hiding (id) -import Common.Model (Category(..), CategoryId) +import Common.Model (Category (..), CategoryId) -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow Category where fromRow = Category <$> diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs index b334a40..41a325d 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Model/Frequency.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Frequency () where -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) -import Common.Model (Frequency) +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"] + _ -> Errors [error "SQLText field required for frequency"] instance ToField Frequency where toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index bbe7657..a69112a 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -9,17 +9,19 @@ module Model.Income , modifiedDuring ) where -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Common.Model (Income(..), IncomeId, User(..), UserId) +import Common.Model (Income (..), IncomeId, User (..), + UserId) -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) +import Model.Query (Query (Query)) +import Resource (Resource, resourceCreatedAt, + resourceDeletedAt, resourceEditedAt) instance Resource Income where resourceCreatedAt = _income_createdAt diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index 8c6a961..c030c58 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -4,16 +4,16 @@ module Model.Init ( getInit ) where -import Common.Model (Init(Init), User(..)) +import Common.Model (Init (Init), User (..)) -import Conf (Conf) +import Conf (Conf) import qualified Conf -import Model.Query (Query) -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment +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 qualified Model.User as User +import Model.Query (Query) +import qualified Model.User as User getInit :: User -> Conf -> Query Init getInit user conf = diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs index 9a4db73..a19f9ae 100644 --- a/server/src/Model/Mail.hs +++ b/server/src/Model/Mail.hs @@ -2,11 +2,11 @@ module Model.Mail ( Mail(..) ) where -import Data.Text (Text) +import Data.Text (Text) data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text + { from :: Text + , to :: [Text] + , subject :: Text , plainBody :: Text } deriving (Eq, Show) diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs index de4abd1..db3f37c 100644 --- a/server/src/Model/Payer.hs +++ b/server/src/Model/Payer.hs @@ -2,14 +2,15 @@ module Model.Payer ( getOrderedExceedingPayers ) where -import Data.Map (Map) -import Data.Time (UTCTime(..), NominalDiffTime) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Time as Time +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time -import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) +import Common.Model (Income (..), IncomeId, Payment (..), User (..), + UserId) type Users = Map UserId User @@ -20,20 +21,20 @@ type Incomes = Map IncomeId Income type Payments = [Payment] data Payer = Payer - { preIncomePaymentSum :: Int + { preIncomePaymentSum :: Int , postIncomePaymentSum :: Int - , _incomes :: [Income] + , _incomes :: [Income] } data PostPaymentPayer = PostPaymentPayer { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float + , _cumulativeIncome :: Int + , ratio :: Float } data ExceedingPayer = ExceedingPayer { _userId :: UserId - , amount :: Int + , amount :: Int } deriving (Show) getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] @@ -72,7 +73,7 @@ useIncomesFrom users incomes payments = mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes in case (firstPaymentTime, mbIncomeTime) of (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing + _ -> Nothing paymentTime :: Payment -> UTCTime paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date @@ -95,7 +96,7 @@ getPayers currentTime users incomes payments = (\p -> case incomesDefined of Nothing -> False - Just t -> paymentTime p >= t + Just t -> paymentTime p >= t ) userId payments @@ -197,7 +198,7 @@ nominalDay :: NominalDiffTime nominalDay = 86400 safeHead :: [a] -> Maybe a -safeHead [] = Nothing +safeHead [] = Nothing safeHead (x : _) = Just x safeMinimum :: (Ord a) => [a] -> Maybe a diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index 14efe77..c1b109f 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment @@ -13,22 +13,26 @@ module Model.Payment , 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 (Only(Only), FromRow(fromRow), ToRow) -import Database.SQLite.Simple.ToField (ToField(toField)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite +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), + ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id) -import Common.Model (Frequency(..), Payment(..), PaymentId, UserId) +import Common.Model (Frequency (..), Payment (..), + PaymentId, UserId) -import Model.Frequency () -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) +import Model.Frequency () +import Model.Query (Query (Query)) +import Resource (Resource, resourceCreatedAt, + resourceDeletedAt, + resourceEditedAt) instance Resource Payment where resourceCreatedAt = _payment_createdAt diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs index 6e1d304..6d02136 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Model/PaymentCategory.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory @@ -7,17 +7,17 @@ module Model.PaymentCategory , save ) where -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Data.Text as T +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Common.Model (CategoryId, PaymentCategory(..)) -import qualified Common.Util.Text as T +import Common.Model (CategoryId, PaymentCategory (..)) +import qualified Common.Util.Text as T -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs index d15fb5f..22ae95b 100644 --- a/server/src/Model/Query.hs +++ b/server/src/Model/Query.hs @@ -3,8 +3,8 @@ module Model.Query , run ) where -import Data.Functor (Functor) -import Database.SQLite.Simple (Connection) +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) import qualified Database.SQLite.Simple as SQLite data Query a = Query (Connection -> IO a) diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index c5182f0..6f38fe7 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -8,25 +8,25 @@ module Model.SignIn , isLastTokenValid ) where -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Data.Int (Int64) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) -import Model.UUID (generateUUID) +import Model.Query (Query (Query)) +import Model.UUID (generateUUID) type SignInId = Int64 data SignIn = SignIn - { id :: SignInId - , token :: Text + { id :: SignInId + , token :: Text , creation :: UTCTime - , email :: Text - , isUsed :: Bool + , email :: Text + , isUsed :: Bool } deriving Show instance FromRow SignIn where diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs index 6cb7ce0..0959a8e 100644 --- a/server/src/Model/UUID.hs +++ b/server/src/Model/UUID.hs @@ -2,9 +2,9 @@ module Model.UUID ( generateUUID ) where -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import Data.Text (Text, pack) +import Data.Text (Text, pack) +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) generateUUID :: IO Text generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs index e14fcef..f17f545 100644 --- a/server/src/Model/User.hs +++ b/server/src/Model/User.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User @@ -8,16 +8,16 @@ module Model.User , delete ) where -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) +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 (UserId, User(..)) +import Common.Model (User (..), UserId) -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field diff --git a/server/src/Resource.hs b/server/src/Resource.hs index f52bbfa..a12a0f2 100644 --- a/server/src/Resource.hs +++ b/server/src/Resource.hs @@ -9,10 +9,10 @@ module Resource , statusDuring ) where -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Time.Clock (UTCTime) class Resource a where resourceCreatedAt :: a -> UTCTime @@ -34,7 +34,7 @@ groupByStatus start end resources = (\m resource -> case statusDuring start end resource of Just status -> M.insertWith (++) status [resource] m - Nothing -> m + Nothing -> m ) M.empty resources diff --git a/server/src/Secure.hs b/server/src/Secure.hs index f427304..88bdcda 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -5,21 +5,21 @@ module Secure , getUserFromToken ) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) -import Model.Query (Query) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User +import Model.Query (Query) +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User loggedAction :: (User -> ActionM ()) -> ActionM () loggedAction action = do diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index f7ba3fd..959f21d 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -4,17 +4,17 @@ module SendMail ( sendMail ) where -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) -import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified MimeMail as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (fromText, toLazyText) +import qualified MimeMail as M -import Model.Mail (Mail(Mail)) +import Model.Mail (Mail (Mail)) sendMail :: Mail -> IO (Either Text ()) sendMail mail = do diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs index 97457c7..e1a94d3 100644 --- a/server/src/Utils/Time.hs +++ b/server/src/Utils/Time.hs @@ -4,10 +4,10 @@ module Utils.Time , timeToDay ) where -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do diff --git a/server/src/Validation.hs b/server/src/Validation.hs index 1f332c9..fd739cd 100644 --- a/server/src/Validation.hs +++ b/server/src/Validation.hs @@ -3,7 +3,7 @@ module Validation , number ) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T nonEmpty :: Text -> Maybe Text diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index 1daca1e..d542fd8 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -4,15 +4,15 @@ module View.Mail.SignIn ( mail ) where -import Data.Text (Text) +import Data.Text (Text) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (User(..)) +import Common.Model (User (..)) -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index b5f2b67..c0e89d5 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -4,28 +4,29 @@ module View.Mail.WeeklyReport ( mail ) where -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T +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 qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model as CM +import Common.Model (Income (..), Payment (..), User (..), + UserId) +import qualified Common.Model as CM import qualified Common.View.Format as Format -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf +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) mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = @@ -65,7 +66,7 @@ payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = case status of Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) where name = formatUserName (_payment_user payment) users amount = Format.price (Conf.currency conf) . _payment_cost $ payment for = _payment_name payment @@ -85,7 +86,7 @@ isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = case status of Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) where name = formatUserName (_income_userId income) users amount = Format.price (Conf.currency conf) . _income_amount $ income for = Format.longDay $ _income_date income diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 6bf9527..ff7bdc7 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -4,23 +4,23 @@ module View.Page ( page ) where -import Data.Text.Internal.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Aeson (encode) -import qualified Data.Aeson.Types as Json +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) -import Text.Blaze.Html -import Text.Blaze.Html5 -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult) -import Design.Global (globalDesign) +import Design.Global (globalDesign) page :: InitResult -> Text page initResult = -- cgit v1.2.3 From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- server/src/Conf.hs | 2 -- server/src/Controller/Category.hs | 7 ++----- server/src/Controller/Income.hs | 7 ++----- server/src/Controller/Index.hs | 15 +++++++------- server/src/Controller/Payment.hs | 2 -- server/src/Controller/SignIn.hs | 15 ++++++-------- server/src/Cookie.hs | 2 -- server/src/Design/Dialog.hs | 2 -- server/src/Design/Errors.hs | 2 -- server/src/Design/Form.hs | 2 -- server/src/Design/Global.hs | 2 -- server/src/Design/Helper.hs | 2 -- server/src/Design/Tooltip.hs | 2 -- server/src/Design/View/Header.hs | 2 -- server/src/Design/View/Payment.hs | 2 -- server/src/Design/View/Payment/Header.hs | 2 -- server/src/Design/View/Payment/Pages.hs | 2 -- server/src/Design/View/Payment/Table.hs | 2 -- server/src/Design/View/SignIn.hs | 2 -- server/src/Design/View/Stat.hs | 2 -- server/src/Design/View/Table.hs | 2 -- server/src/Design/Views.hs | 2 -- server/src/Job/Daemon.hs | 2 +- server/src/Job/Model.hs | 2 -- server/src/Job/MonthlyPayment.hs | 2 +- server/src/Json.hs | 3 --- server/src/LoginSession.hs | 2 -- server/src/Main.hs | 7 ++++--- server/src/MimeMail.hs | 2 -- server/src/Model/Category.hs | 1 - server/src/Model/Frequency.hs | 3 --- server/src/Model/Income.hs | 1 - server/src/Model/Init.hs | 2 -- server/src/Model/Payment.hs | 1 - server/src/Model/PaymentCategory.hs | 1 - server/src/Model/SignIn.hs | 2 -- server/src/Model/User.hs | 1 - server/src/Secure.hs | 9 +++----- server/src/SendMail.hs | 2 -- server/src/Util/Time.hs | 25 +++++++++++++++++++++++ server/src/Utils/Time.hs | 25 ----------------------- server/src/View/Mail/SignIn.hs | 19 ++++++++--------- server/src/View/Mail/WeeklyReport.hs | 35 +++++++++++++++----------------- server/src/View/Page.hs | 7 ++----- 44 files changed, 77 insertions(+), 157 deletions(-) create mode 100644 server/src/Util/Time.hs delete mode 100644 server/src/Utils/Time.hs (limited to 'server/src') diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 299f071..2422a93 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Conf ( get , Conf(..) diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index a646496..5565b43 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Category ( create , edit @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CategoryId, CreateCategory (..), EditCategory (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Category as Category @@ -50,5 +47,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index c42f6a7..19f0cfc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Income ( create , editOwn @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Income as Income @@ -45,5 +42,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index bf4859d..f05ce6f 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -10,10 +10,9 @@ import Network.HTTP.Types.Status (ok200) import Prelude hiding (error) import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key import Common.Model (InitResult (..), User (..)) +import Common.Msg (Key) +import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession @@ -31,7 +30,7 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey + return . InitEmpty . Left . Msg.get $ errorKey Right user -> liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do @@ -54,23 +53,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ Key.SignIn_LinkInvalid + return . Left $ Msg.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ Key.SignIn_LinkUsed + return . Left $ Msg.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ Key.SignIn_LinkExpired + return . Left $ Msg.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e4104eb..c6c874a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Payment ( list , create diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 5552781..cf92c9f 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.SignIn ( signIn ) where @@ -11,9 +9,8 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (SignIn (..)) +import qualified Common.Msg as Msg import Conf (Conf) import qualified Conf @@ -40,8 +37,8 @@ signIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) + 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/Cookie.hs b/server/src/Cookie.hs index 511dd42..f79a1fa 100644 --- a/server/src/Cookie.hs +++ b/server/src/Cookie.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Cookie ( makeSimpleCookie , setCookie diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs index 6759606..034a8b1 100644 --- a/server/src/Design/Dialog.hs +++ b/server/src/Design/Dialog.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Dialog ( design ) where diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs index 2c6c16b..9f435eb 100644 --- a/server/src/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Errors ( design ) where diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index a4a1de0..be0e74f 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Form ( design ) where diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 1fe6a80..34d772e 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Global ( globalDesign ) where diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 0913511..9bf7878 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Helper ( clearFix , button diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs index 57aec33..eef804e 100644 --- a/server/src/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Tooltip ( design ) where diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index d05f748..792d482 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Header ( design ) where diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 62f7061..0d59fa0 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment ( design ) where diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index d87e95b..36bc8d9 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Header ( design ) where diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index f6660a1..2028c1b 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Pages ( design ) where diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index 243d7f4..26dc9ed 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Table ( design ) where diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 2b1252f..4d4be7b 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.SignIn ( design ) where diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index b10dd7b..4d7021e 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Stat ( design ) where diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index fd55656..cd406fc 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Table ( design ) where diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 1157b68..a73a1fa 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Views ( design ) where diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 26977d1..d8cd522 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -14,7 +14,7 @@ import Job.Model (actualizeLastCheck, actualizeLastExecution, import Job.MonthlyPayment (monthlyPayment) import Job.WeeklyReport (weeklyReport) import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Util.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index b90dca0..a5fa62b 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Job.Model ( Job(..) , getLastExecution diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 8cb1c27..ca7e007 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -8,7 +8,7 @@ import Common.Model (Frequency (..), Payment (..)) import qualified Model.Payment as Payment import qualified Model.Query as Query -import Utils.Time (timeToDay) +import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do diff --git a/server/src/Json.hs b/server/src/Json.hs index eb5c572..6d40305 100644 --- a/server/src/Json.hs +++ b/server/src/Json.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - module Json ( jsonObject , jsonId diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs index beca697..86f1329 100644 --- a/server/src/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module LoginSession ( put , get diff --git a/server/src/Main.hs b/server/src/Main.hs index 5ac68db..d7b9b93 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - import Control.Applicative (liftA3) import Control.Monad.IO.Class (liftIO) @@ -9,6 +7,8 @@ import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static import Web.Scotty +import Common.Model (Frequency (..), Payment (..)) + import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income @@ -35,7 +35,8 @@ main = do time <- liftIO Time.getCurrentTime (users, incomes, payments) <- liftIO . Query.run $ liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments + let punctualPayments = filter ((==) Punctual . _payment_frequency) payments + exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments text . LT.pack . show $ exceedingPayers get "/" $ do diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs index 7fe98ed..c994905 100644 --- a/server/src/MimeMail.hs +++ b/server/src/MimeMail.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module MimeMail ( -- * Datatypes Boundary (..) diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs index b972ebd..ee406bc 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Model/Category.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs index 41a325d..c29cf37 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Model/Frequency.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Frequency () where diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index a69112a..a6174bc 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index c030c58..be44c72 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Model.Init ( getInit ) where diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index c1b109f..33551e5 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs index 6d02136..c60c1a2 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Model/PaymentCategory.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index 6f38fe7..0cc4a03 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Model.SignIn ( SignIn(..) , createSignInToken diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs index f17f545..8dc1fc8 100644 --- a/server/src/Model/User.hs +++ b/server/src/Model/User.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 88bdcda..6e5b998 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Secure ( loggedAction , getUserFromToken @@ -11,9 +9,8 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (User) +import qualified Common.Msg as Msg import qualified LoginSession import Model.Query (Query) @@ -32,10 +29,10 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized + html . fromStrict . Msg.get $ Msg.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden + html . fromStrict . Msg.get $ Msg.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index 959f21d..d00912f 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module SendMail ( sendMail ) where diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs new file mode 100644 index 0000000..3e0856d --- /dev/null +++ b/server/src/Util/Time.hs @@ -0,0 +1,25 @@ +module Util.Time + ( belongToCurrentMonth + , belongToCurrentWeek + , timeToDay + ) where + +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs deleted file mode 100644 index e1a94d3..0000000 --- a/server/src/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= 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/SignIn.hs b/server/src/View/Mail/SignIn.hs index d542fd8..22c3cb0 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -1,24 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Mail.SignIn ( mail ) where -import Data.Text (Text) +import Data.Text (Text) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User (..)) +import Common.Model (User (..)) +import qualified Common.Msg as Msg -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) + , M.subject = Msg.get Msg.SignIn_MailTitle + , M.plainBody = 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 c0e89d5..4ad8b77 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Mail.WeeklyReport ( mail ) where @@ -13,11 +11,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (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) @@ -34,9 +31,9 @@ mail conf users payments incomes start end = { M.from = Conf.noReplyMail conf , M.to = map _user_email users , M.subject = T.concat - [ Message.get Key.App_Title + [ Msg.get Msg.App_Title , " − " - , Message.get Key.WeeklyReport_Title + , Msg.get Msg.WeeklyReport_Title ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -45,7 +42,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - Message.get Key.WeeklyReport_Empty + Msg.get Msg.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -56,17 +53,17 @@ paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = section sectionTitle sectionItems where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionTitle = Msg.get $ case status of + 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 payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at) + _ -> Msg.get (Msg.WeeklyReport_PayedFor name amount for at) where name = formatUserName (_payment_user payment) users amount = Format.price (Conf.currency conf) . _payment_cost $ payment for = _payment_name payment @@ -76,17 +73,17 @@ incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = section sectionTitle sectionItems where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionTitle = Msg.get $ case status of + 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 isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for) + _ -> Msg.get (Msg.WeeklyReport_PayedFrom name amount for) where name = formatUserName (_income_userId income) users amount = Format.price (Conf.currency conf) . _income_amount $ income for = Format.longDay $ _income_date income diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index ff7bdc7..27b4f26 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Page ( page ) where @@ -16,9 +14,8 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (InitResult) +import qualified Common.Msg as Msg import Design.Global (globalDesign) @@ -28,7 +25,7 @@ page initResult = H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ Message.get Key.App_Title) + H.title (toHtml $ Msg.get Msg.App_Title) script ! src "javascript/main.js" $ "" jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" -- cgit v1.2.3 From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:00:07 +0100 Subject: Add exceeding payer block --- server/src/Design/View/Header.hs | 2 +- server/src/Main.hs | 4 +- server/src/Model/Payer.hs | 217 --------------------------------------- 3 files changed, 3 insertions(+), 220 deletions(-) delete mode 100644 server/src/Model/Payer.hs (limited to 'server/src') diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 792d482..904a2f5 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -57,7 +57,7 @@ design = do ".signOut" ? do Helper.waitable - heightMedia + display flex svg ? do Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) diff --git a/server/src/Main.hs b/server/src/Main.hs index d7b9b93..c8080dc 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -8,6 +8,7 @@ import Network.Wai.Middleware.Static import Web.Scotty import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Model as CM import qualified Conf import qualified Controller.Category as Category @@ -18,7 +19,6 @@ import qualified Controller.SignIn as SignIn import qualified Data.Time as Time import Job.Daemon (runDaemons) import qualified Model.Income as IncomeM -import Model.Payer (getOrderedExceedingPayers) import qualified Model.Payment as PaymentM import qualified Model.Query as Query import qualified Model.User as UserM @@ -36,7 +36,7 @@ main = do (users, incomes, payments) <- liftIO . Query.run $ liftA3 (,,) UserM.list IncomeM.list PaymentM.list let punctualPayments = filter ((==) Punctual . _payment_frequency) payments - exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments + exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments text . LT.pack . show $ exceedingPayers get "/" $ do diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs deleted file mode 100644 index db3f37c..0000000 --- a/server/src/Model/Payer.hs +++ /dev/null @@ -1,217 +0,0 @@ -module Model.Payer - ( getOrderedExceedingPayers - ) where - -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time - -import Common.Model (Income (..), IncomeId, Payment (..), User (..), - UserId) - -type Users = Map UserId User - -type Payers = Map UserId Payer - -type Incomes = Map IncomeId Income - -type Payments = [Payment] - -data Payer = Payer - { preIncomePaymentSum :: Int - , postIncomePaymentSum :: Int - , _incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float - } - -data ExceedingPayer = ExceedingPayer - { _userId :: UserId - , amount :: Int - } deriving (Show) - -getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] -getOrderedExceedingPayers currentTime users incomes payments = - let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users - incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes - payers = getPayers currentTime usersMap incomesMap payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts - . Map.toList - . Map.map preIncomePaymentSum - $ payers - mbSince = useIncomesFrom usersMap incomesMap payments - in case mbSince of - Just since -> - let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - safeMaximum - . map (ratio . snd) - . Map.toList - $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . Map.toList - . Map.map (getFinalDiff maxRatio) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime -useIncomesFrom users incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing - -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date - -getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Map.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in Map.fromList - . map (\userId -> - ( userId - , Payer - { preIncomePaymentSum = - totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> paymentTime p >= t - ) - userId - payments - , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) - } - ) - ) - $ userIds - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _preIncomePaymentSum = preIncomePaymentSum payer - , _cumulativeIncome = cumulativeIncome - , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) - in postIncomeDiff + _preIncomePaymentSum payer - -incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } - else Nothing - x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments -- cgit v1.2.3 From 554880727d833befab00666c7a4f95611e8370b9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:39:11 +0100 Subject: Remove local MimeMail --- server/src/Design/Helper.hs | 6 +- server/src/MimeMail.hs | 672 -------------------------------------------- server/src/SendMail.hs | 2 +- 3 files changed, 4 insertions(+), 676 deletions(-) delete mode 100644 server/src/MimeMail.hs (limited to 'server/src') diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 9bf7878..89f5958 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -41,12 +41,12 @@ button backgroundCol textCol h focusOp = do waitable :: Css waitable = do + ".content" ? display flex svg # ".loader" ? display none + ".waiting" & do ".content" ? do - display flex - fontSize (px 0) - opacity 0 + display none svg # ".loader" ? do display block rotateKeyframes diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs deleted file mode 100644 index c994905..0000000 --- a/server/src/MimeMail.hs +++ /dev/null @@ -1,672 +0,0 @@ -module MimeMail - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , sendmailCustomCaptureOutput - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachmentCid - , addAttachments - , addAttachmentBS - , addAttachmentBSCid - , addAttachmentsBS - , renderAddress - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char.Utf8 -import Control.Arrow -import Control.Concurrent (forkIO, newEmptyMVar, - putMVar, takeMVar) -import Control.Exception (ErrorCall (ErrorCall), - throwIO) -import Control.Monad (foldM, void, (<=<)) -import Data.Bits (shiftR, (.&.)) -import qualified Data.ByteString as S -import qualified Data.ByteString.Base64 as Base64 -import Data.ByteString.Char8 () -import qualified Data.ByteString.Lazy as L -import Data.Char (isAscii, isControl) -import Data.List (intersperse) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.Word (Word8) -import System.Exit -import System.FilePath (takeFileName) -import System.IO -import System.Process -import System.Random - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - ((:) ("Content-Type", contentType)) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - $ headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\n" - , finalBuilder - ] - --- | Format an E-Mail address according to the name-addr form (see: RFC5322 --- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') --- This can be handy for adding custom headers that require such format. --- --- @since 0.4.11 -renderAddress :: Address -> Text -renderAddress address = - TE.decodeUtf8 $ toByteString $ showAddress address - --- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) -sanitizeFieldName :: S.ByteString -> S.ByteString -sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString (sanitizeFieldName k) - , fromByteString ": " - , encodeIfNeeded (sanitizeHeader v) - , fromByteString "\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (sanitizeHeader $ addressEmail a) - , fromByteString ">" - ] - --- Filter out control characters to prevent CRLF injection. -sanitizeHeader :: Text -> Text -sanitizeHeader = T.filter (not . isControl) - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\n" - , mconcat $ map showHeader headers - , fromByteString "\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -sendmailPath = "sendmail" - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs - --- | Like 'sendmailCustom', but also returns sendmail's output to stderr and --- stdout as strict ByteStrings. --- --- Since 0.4.9 -sendmailCustomCaptureOutput :: FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs - -sendmailCustomAux :: Bool - -> FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomAux captureOut sm opts lbs = do - let baseOpts = (proc sm opts) { std_in = CreatePipe } - pOpts = if captureOut - then baseOpts { std_out = CreatePipe - , std_err = CreatePipe - } - else baseOpts - (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts - L.hPut hin lbs - hClose hin - errMVar <- newEmptyMVar - outMVar <- newEmptyMVar - case (mHOut, mHErr) of - (Nothing, Nothing) -> return () - (Just hOut, Just hErr) -> do - void . forkIO $ S.hGetContents hOut >>= putMVar outMVar - void . forkIO $ S.hGetContents hErr >>= putMVar errMVar - _ -> error "error in sendmailCustomAux: missing a handle" - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> if captureOut - then do - errOutput <- takeMVar errMVar - outOutput <- takeMVar outMVar - return (outOutput, errOutput) - else return (S.empty, S.empty) - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - part <- getAttachmentPart ct fn - return $ addPart [part] mail - --- | Add an attachment from a file and construct a 'Part' --- with the specified content id in the Content-ID header. --- --- @since 0.4.12 -addAttachmentCid :: Text -- ^ content type - -> FilePath -- ^ file name - -> Text -- ^ content ID - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = - getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = getAttachmentPartBS ct fn content - in addPart [part] mail - --- | @since 0.4.12 -addAttachmentBSCid :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Text -- ^ content ID - -> Mail -> Mail -addAttachmentBSCid ct fn content cid mail = - let part = addHeader $ getAttachmentPartBS ct fn content - in addPart [part] mail - where - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -getAttachmentPartBS :: Text - -> Text - -> L.ByteString - -> Part -getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content - -getAttachmentPart :: Text -> FilePath -> IO Part -getAttachmentPart ct fn = do - content <- L.readFile fn - return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 46 = QPCEscape - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index d00912f..c15ed62 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -5,12 +5,12 @@ module SendMail import Control.Arrow (left) import Control.Exception (SomeException, try) import Data.Either (isLeft) +import qualified Network.Mail.Mime as M import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (fromText, toLazyText) -import qualified MimeMail as M import Model.Mail (Mail (Mail)) -- cgit v1.2.3 From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 28 Nov 2017 09:11:19 +0100 Subject: Add search for payments --- server/src/Design/Global.hs | 26 ++++++++++++++++++++++++ server/src/Design/Helper.hs | 29 --------------------------- server/src/Design/View/Header.hs | 8 +++----- server/src/Design/View/Payment/Header.hs | 34 +++++++++++++++++--------------- server/src/Job/Model.hs | 14 ++++++++----- 5 files changed, 56 insertions(+), 55 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 34d772e..5e5035c 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -71,3 +71,29 @@ global = do ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten svg ? height (pct 100) + + button ? do + ".content" ? display flex + svg # ".loader" ? display none + + ".waiting" & do + ".content" ? do + display none + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 89f5958..6980c71 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,7 +1,6 @@ module Design.Helper ( clearFix , button - , waitable , input , centeredWithMargin , verticalCentering @@ -37,20 +36,6 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) - waitable - -waitable :: Css -waitable = do - ".content" ? display flex - svg # ".loader" ? display none - - ".waiting" & do - ".content" ? do - display none - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation input :: Double -> Css input h = do @@ -72,17 +57,3 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 904a2f5..97f1802 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -2,13 +2,12 @@ module Design.View.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import Clay -import Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Media as Media +import Design.Color as Color +import qualified Design.Media as Media design :: Css design = do @@ -56,7 +55,6 @@ design = do Media.tabletDesktop $ headerPadding ".signOut" ? do - Helper.waitable display flex svg ? do Media.tabletDesktop $ width (px 30) diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 36bc8d9..80c5436 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -50,22 +50,24 @@ design = do ".searchLine" ? do marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none + Media.mobile $ textAlign (alignSide sideCenter) + + ".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 + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none ".infos" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index a5fa62b..1dd6c63 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -5,7 +5,6 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) import Data.Time.Clock (UTCTime, getCurrentTime) import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -24,15 +23,20 @@ data Job = Job getLastExecution :: Kind -> Query (Maybe UTCTime) getLastExecution jobKind = Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time + result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime] + return $ case result of + [Only time] -> Just time + _ -> Nothing ) actualizeLastExecution :: Kind -> UTCTime -> Query () actualizeLastExecution jobKind time = Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result + result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int] + let hasJob = case result of + [Only _] -> True + _ -> False + if hasJob then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) ) -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- server/src/Conf.hs | 4 +- server/src/Controller/Index.hs | 77 ++++++++++++++++++++++++---------- server/src/Controller/Payment.hs | 2 +- server/src/Controller/SignIn.hs | 44 -------------------- server/src/Design/View/SignIn.hs | 2 +- server/src/Job/MonthlyPayment.hs | 2 +- server/src/Job/WeeklyReport.hs | 7 +--- server/src/Main.hs | 81 +++++++++++++----------------------- server/src/Model/Income.hs | 12 +----- server/src/Model/Init.hs | 2 +- server/src/Model/Mail.hs | 8 ++-- server/src/Model/Payment.hs | 41 +++++++----------- server/src/SendMail.hs | 39 +++++++++++++---- server/src/View/Mail/SignIn.hs | 2 +- server/src/View/Mail/WeeklyReport.hs | 32 +++++++++++--- server/src/View/Page.hs | 6 +-- 16 files changed, 176 insertions(+), 185 deletions(-) delete mode 100644 server/src/Controller/SignIn.hs (limited to 'server/src') 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 -- cgit v1.2.3 From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 5 Jan 2018 14:45:47 +0100 Subject: Add modal component --- server/src/Design/Dialog.hs | 22 ---------------------- server/src/Design/Global.hs | 16 ++++++++-------- server/src/Design/Modal.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 51 insertions(+), 30 deletions(-) delete mode 100644 server/src/Design/Dialog.hs create mode 100644 server/src/Design/Modal.hs (limited to 'server/src') diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs deleted file mode 100644 index 034a8b1..0000000 --- a/server/src/Design/Dialog.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 5e5035c..4da4ffb 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -3,19 +3,17 @@ module Design.Global ) where import Clay - import Data.Text.Lazy (Text) -import qualified Design.Dialog as Dialog -import qualified Design.Errors as Errors -import qualified Design.Form as Form -import qualified Design.Tooltip as Tooltip -import qualified Design.Views as Views - import qualified Design.Color as Color import qualified Design.Constants as Constants +import qualified Design.Errors as Errors +import qualified Design.Form as Form import qualified Design.Helper as Helper import qualified Design.Media as Media +import qualified Design.Modal as Modal +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views globalDesign :: Text globalDesign = renderWith compact [] global @@ -23,7 +21,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design - ".dialog" ? Dialog.design + ".modal" ? Modal.design ".tooltip" ? Tooltip.design Views.design Form.design @@ -84,6 +82,8 @@ global = do rotateKeyframes rotateAnimation + select ? cursor pointer + rotateAnimation :: Css rotateAnimation = do animationName "rotate" diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs new file mode 100644 index 0000000..2612257 --- /dev/null +++ b/server/src/Design/Modal.hs @@ -0,0 +1,43 @@ +module Design.Modal + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +design :: Css +design = do + + ".curtain" ? do + position fixed + cursor pointer + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + backgroundColor (rgba 0 0 0 0.5) + zIndex 1000 + opacity 1 + transition "all" (sec 0.2) ease (sec 0) + + ".content" ? do + minWidth (px 270) + position fixed + top (pct 25) + left (pct 50) + "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) + + ".paymentModal" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentModal" <> ".deleteIncomeModal" ? do + h1 ? marginBottom (em 1.5) -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- server/src/Controller/Category.hs | 30 +++--- server/src/Controller/Income.hs | 8 +- server/src/Controller/Index.hs | 18 ++-- server/src/Controller/Payment.hs | 40 +++---- server/src/Design/Form.hs | 12 ++- server/src/Design/Modal.hs | 8 +- server/src/Design/View/Payment.hs | 2 + server/src/Design/View/Payment/Add.hs | 32 ++++++ server/src/Design/View/Payment/Header.hs | 9 +- server/src/Job/MonthlyPayment.hs | 16 +-- server/src/Job/WeeklyReport.hs | 8 +- server/src/Model/Category.hs | 78 -------------- server/src/Model/Frequency.hs | 20 ---- server/src/Model/Income.hs | 88 ---------------- server/src/Model/IncomeResource.hs | 15 +++ server/src/Model/Init.hs | 25 ----- server/src/Model/Payment.hs | 169 ------------------------------ server/src/Model/PaymentCategory.hs | 61 ----------- server/src/Model/PaymentResource.hs | 15 +++ server/src/Model/User.hs | 48 --------- server/src/Persistence/Category.hs | 79 ++++++++++++++ server/src/Persistence/Frequency.hs | 23 ++++ server/src/Persistence/Income.hs | 88 ++++++++++++++++ server/src/Persistence/Init.hs | 25 +++++ server/src/Persistence/Payment.hs | 169 ++++++++++++++++++++++++++++++ server/src/Persistence/PaymentCategory.hs | 66 ++++++++++++ server/src/Persistence/User.hs | 37 +++++++ server/src/Secure.hs | 4 +- server/src/SendMail.hs | 1 + server/src/Util/Time.hs | 17 ++- server/src/View/Mail/WeeklyReport.hs | 55 +++++----- 31 files changed, 662 insertions(+), 604 deletions(-) create mode 100644 server/src/Design/View/Payment/Add.hs delete mode 100644 server/src/Model/Category.hs delete mode 100644 server/src/Model/Frequency.hs delete mode 100644 server/src/Model/Income.hs create mode 100644 server/src/Model/IncomeResource.hs delete mode 100644 server/src/Model/Init.hs delete mode 100644 server/src/Model/Payment.hs delete mode 100644 server/src/Model/PaymentCategory.hs create mode 100644 server/src/Model/PaymentResource.hs delete mode 100644 server/src/Model/User.hs create mode 100644 server/src/Persistence/Category.hs create mode 100644 server/src/Persistence/Frequency.hs create mode 100644 server/src/Persistence/Income.hs create mode 100644 server/src/Persistence/Init.hs create mode 100644 server/src/Persistence/Payment.hs create mode 100644 server/src/Persistence/PaymentCategory.hs create mode 100644 server/src/Persistence/User.hs (limited to 'server/src') 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/Category.hs b/server/src/Model/Category.hs deleted file mode 100644 index ee406bc..0000000 --- a/server/src/Model/Category.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category - ( list - , create - , edit - , delete - ) where - -import Data.Maybe (isJust, 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 (Category (..), CategoryId) - -import Model.Query (Query (Query)) - -instance FromRow Category where - fromRow = Category <$> - 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" - ) - -create :: Text -> Text -> Query CategoryId -create categoryName categoryColor = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn - ) - -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]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) - return True - else - return False - ) - -delete :: CategoryId -> Query Bool -delete categoryId = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) - return True - else - return False - ) diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs deleted file mode 100644 index c29cf37..0000000 --- a/server/src/Model/Frequency.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where - -import qualified Data.Text as T -import Database.SQLite.Simple (SQLData (SQLText)) -import Database.SQLite.Simple.FromField (FromField (fromField), - fieldData) -import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) -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"] - -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs deleted file mode 100644 index 4938e50..0000000 --- a/server/src/Model/Income.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income - ( list - , create - , editOwn - , deleteOwn - ) where - -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -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 (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 - -instance FromRow Income where - fromRow = Income <$> - 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") - -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn - ) - -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) - case mbIncome of - Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False - ) 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/Payment.hs b/server/src/Model/Payment.hs deleted file mode 100644 index 5b29409..0000000 --- a/server/src/Model/Payment.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment - ( Payment(..) - , find - , listActive - , listPunctual - , listActiveMonthlyOrderedByName - , create - , createMany - , editOwn - , deleteOwn - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only), - ToRow) -import qualified Database.SQLite.Simple as SQLite -import Database.SQLite.Simple.ToField (ToField (toField)) -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) - -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt - -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -instance ToRow Payment where - toRow p = - [ toField (_payment_user p) - , toField (_payment_name p) - , toField (_payment_cost p) - , toField (_payment_date p) - , toField (_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) - ) - -listActive :: Query [Payment] -listActive = - Query (\conn -> - 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)) - -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)) - -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False - ) diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs deleted file mode 100644 index c60c1a2..0000000 --- a/server/src/Model/PaymentCategory.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory - ( list - , listByCategory - , save - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory (..)) -import qualified Common.Util.Text as T - -import Model.Query (Query (Query)) - -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [PaymentCategory] -list = Query (\conn -> 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) - ) - -save :: Text -> CategoryId -> Query () -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) - ) - where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower 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/Persistence/Category.hs b/server/src/Persistence/Category.hs new file mode 100644 index 0000000..2afe5db --- /dev/null +++ b/server/src/Persistence/Category.hs @@ -0,0 +1,79 @@ +module Persistence.Category + ( list + , create + , edit + , delete + ) where + +import Data.Maybe (isJust, 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 (Category (..), CategoryId) + +import Model.Query (Query (Query)) + +newtype Row = Row Category + +instance FromRow Row where + fromRow = Row <$> (Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [Category] +list = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query CategoryId +create categoryName categoryColor = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" + (categoryName, categoryColor, now) + SQLite.lastInsertRowId conn + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit categoryId categoryName categoryColor = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" + (now, categoryName, categoryColor, categoryId) + return True + else + return False + ) + +delete :: CategoryId -> Query Bool +delete categoryId = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + return True + else + return False + ) diff --git a/server/src/Persistence/Frequency.hs b/server/src/Persistence/Frequency.hs new file mode 100644 index 0000000..edaa844 --- /dev/null +++ b/server/src/Persistence/Frequency.hs @@ -0,0 +1,23 @@ +module Persistence.Frequency + ( FrequencyField(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +import Common.Model (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 FrequencyField where + toField (FrequencyField f) = SQLText . T.pack . show $ f diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs new file mode 100644 index 0000000..a863f85 --- /dev/null +++ b/server/src/Persistence/Income.hs @@ -0,0 +1,88 @@ +module Persistence.Income + ( list + , create + , editOwn + , deleteOwn + ) where + +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +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 (Income (..), IncomeId, User (..), + UserId) + +import Model.Query (Query (Query)) + +newtype Row = Row Income + +instance FromRow Row where + fromRow = Row <$> (Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [Income] +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 = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" + (incomeUserId, incomeDate, incomeAmount, now) + SQLite.lastInsertRowId conn + ) + +editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool +editOwn incomeUserId incomeId incomeDate incomeAmount = + Query (\conn -> do + 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 + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" + (now, incomeDate, incomeAmount, incomeId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: User -> IncomeId -> Query Bool +deleteOwn user incomeId = + Query (\conn -> do + 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 + then do + now <- getCurrentTime + SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) + return True + else + return False + Nothing -> + return False + ) 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/Persistence/Payment.hs b/server/src/Persistence/Payment.hs new file mode 100644 index 0000000..32600d7 --- /dev/null +++ b/server/src/Persistence/Payment.hs @@ -0,0 +1,169 @@ +module Persistence.Payment + ( Payment(..) + , find + , listActive + , listPunctual + , listActiveMonthlyOrderedByName + , create + , createMany + , editOwn + , deleteOwn + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only), + ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id) + +import Common.Model (Frequency (..), Payment (..), + PaymentId, UserId) + +import Model.Query (Query (Query)) +import Persistence.Frequency (FrequencyField (..)) + +newtype Row = Row Payment + +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) + +newtype InsertRow = InsertRow Payment + +instance ToRow InsertRow where + toRow (InsertRow p) = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (FrequencyField (_payment_frequency p)) + , toField (_payment_createdAt p) + ] + +find :: PaymentId -> Query (Maybe Payment) +find 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 -> do + map (\(Row p) -> p) <$> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + ) + +listPunctual :: Query [Payment] +listPunctual = + 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 -> 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 = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) + SQLite.lastInsertRowId conn + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (map InsertRow payments) + ) + +editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) + (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: UserId -> PaymentId -> Query Bool +deleteOwn userId paymentId = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just (Row payment) -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE payment SET deleted_at = ? WHERE id = ?" + (now, paymentId) + return True + else + return False + Nothing -> + return False + ) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs new file mode 100644 index 0000000..1e377b1 --- /dev/null +++ b/server/src/Persistence/PaymentCategory.hs @@ -0,0 +1,66 @@ +module Persistence.PaymentCategory + ( list + , listByCategory + , save + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (CategoryId, PaymentCategory (..)) +import qualified Common.Util.Text as T + +import Model.Query (Query (Query)) + +newtype Row = Row PaymentCategory + +instance FromRow Row where + fromRow = Row <$> (PaymentCategory <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [PaymentCategory] +list = + Query (\conn -> do + map (\(Row pc) -> pc) <$> + SQLite.query_ conn "SELECT * from payment_category" + ) + +listByCategory :: CategoryId -> Query [PaymentCategory] +listByCategory 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 + hasPaymentCategory <- isJust <$> listToMaybe <$> + (SQLite.query + conn + "SELECT * FROM payment_category WHERE name = ?" + (Only (formatPaymentName newName)) :: IO [Row]) + if hasPaymentCategory + then + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formatPaymentName newName) + else do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formatPaymentName newName, categoryId, now) + ) + where + formatPaymentName :: Text -> Text + formatPaymentName = T.unaccent . T.toLower 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 = -- cgit v1.2.3 From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Oct 2018 17:57:58 +0100 Subject: Delete payment --- server/src/Controller/Payment.hs | 17 ++++++++++++----- server/src/Design/Modal.hs | 9 +++++++-- server/src/Design/View/Payment.hs | 2 -- server/src/Design/View/Payment/Delete.hs | 32 ++++++++++++++++++++++++++++++++ server/src/Main.hs | 6 +++--- server/src/Validation.hs | 23 ----------------------- server/src/Validation/Atomic.hs | 32 ++++++++++++++++++++++++++++++++ server/src/Validation/CreatePayment.hs | 25 +++++++++++++++++++++++++ 8 files changed, 111 insertions(+), 35 deletions(-) create mode 100644 server/src/Design/View/Payment/Delete.hs delete mode 100644 server/src/Validation.hs create mode 100644 server/src/Validation/Atomic.hs create mode 100644 server/src/Validation/CreatePayment.hs (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e1936f0..4edbf6a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -18,6 +18,7 @@ import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +import qualified Validation.CreatePayment as CreatePaymentValidation list :: ActionM () list = @@ -26,12 +27,18 @@ list = ) create :: CreatePayment -> ActionM () -create (CreatePayment name cost date category frequency) = +create createPayment@(CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + case CreatePaymentValidation.validate createPayment of + Nothing -> + (liftIO . Query.run $ do + PaymentCategoryPersistence.save name category + PaymentPersistence.create (_user_id user) name cost date frequency + ) >>= Json.jsonId + Just validationError -> + do + status Status.badRequest400 + json validationError ) editOwn :: EditPayment -> ActionM () diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index ce427c0..2677fd8 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -2,9 +2,11 @@ module Design.Modal ( design ) where -import Data.Monoid ((<>)) - import Clay +import Data.Monoid ((<>)) + +import qualified Design.View.Payment.Add as Add +import qualified Design.View.Payment.Delete as Delete design :: Css design = do @@ -31,6 +33,9 @@ design = do sym borderRadius (px 5) boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + ".add" ? Add.design + ".delete" ? Delete.design + ".paymentModal" & do ".radioGroup" ? ".title" ? display none ".selectInput" ? do diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 2102ff8..0d59fa0 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,7 +4,6 @@ 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 @@ -12,6 +11,5 @@ 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/Delete.hs b/server/src/Design/View/Payment/Delete.hs new file mode 100644 index 0000000..5597f5b --- /dev/null +++ b/server/src/Design/View/Payment/Delete.hs @@ -0,0 +1,32 @@ +module Design.View.Payment.Delete + ( 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 + ".deleteHeader" ? 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) + + ".deleteContent" ? 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/Main.hs b/server/src/Main.hs index e298a06..745071c 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -37,7 +37,7 @@ main = do S.put "/payment" $ S.jsonData >>= Payment.editOwn - S.delete "/payment" $ do + S.delete "/payment/:id" $ do paymentId <- S.param "id" Payment.deleteOwn paymentId @@ -47,7 +47,7 @@ main = do S.put "/income" $ S.jsonData >>= Income.editOwn - S.delete "/income" $ do + S.delete "/income/:id" $ do incomeId <- S.param "id" Income.deleteOwn incomeId @@ -57,6 +57,6 @@ main = do S.put "/category" $ S.jsonData >>= Category.edit - S.delete "/category" $ do + S.delete "/category/:id" $ do categoryId <- S.param "id" Category.delete categoryId diff --git a/server/src/Validation.hs b/server/src/Validation.hs deleted file mode 100644 index fd739cd..0000000 --- a/server/src/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs new file mode 100644 index 0000000..d15ad49 --- /dev/null +++ b/server/src/Validation/Atomic.hs @@ -0,0 +1,32 @@ +module Validation.Atomic + ( nonEmpty + , nonNullNumber + -- , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import qualified Common.Msg as Msg + +nonEmpty :: Text -> Maybe Text +nonEmpty str = + if T.null str + then Just $ Msg.get Msg.Form_NonEmpty + else Nothing + +nonNullNumber :: Int -> Maybe Text +nonNullNumber n = + if n == 0 + then Just $ Msg.get Msg.Form_NonNullNumber + else Nothing + +-- number :: (Int -> Bool) -> Text -> Maybe Int +-- number numberForm str = +-- case reads (T.unpack str) :: [(Int, String)] of +-- (num, _) : _ -> +-- if numberForm num +-- then Just num +-- else Nothing +-- _ -> +-- Nothing diff --git a/server/src/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs new file mode 100644 index 0000000..fbcdb7c --- /dev/null +++ b/server/src/Validation/CreatePayment.hs @@ -0,0 +1,25 @@ +module Validation.CreatePayment + ( validate + ) where + +import Data.Maybe (catMaybes) + +import Common.Model.CreatePayment (CreatePayment (..), + CreatePaymentError (..)) +import qualified Validation.Atomic as Atomic + +validate :: CreatePayment -> Maybe CreatePaymentError +validate p = + if not . null . catMaybes $ [ nameError, costError ] + then Just createPaymentError + else Nothing + where + nameError = Atomic.nonEmpty . _createPayment_name $ p + costError = Atomic.nonNullNumber . _createPayment_cost $ p + createPaymentError = CreatePaymentError + { _createPaymentError_name = nameError + , _createPaymentError_cost = costError + , _createPaymentError_date = Nothing + , _createPaymentError_category = Nothing + , _createPaymentError_frequency = Nothing + } -- cgit v1.2.3 From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 18:04:58 +0100 Subject: Update table when adding or removing a payment --- server/src/Controller/Payment.hs | 4 +--- server/src/Design/Global.hs | 2 ++ server/src/Persistence/Payment.hs | 21 ++++++++++++++++----- 3 files changed, 19 insertions(+), 8 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 4edbf6a..fb7fcb2 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -12,8 +12,6 @@ import Web.Scotty import Common.Model (CreatePayment (..), EditPayment (..), PaymentId, User (..)) - -import qualified Json import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -34,7 +32,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do PaymentCategoryPersistence.save name category PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + ) >>= json Just validationError -> do status Status.badRequest400 diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 4da4ffb..de8dd61 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -29,6 +29,8 @@ global = do body ? do minWidth (px 320) fontFamily ["Cantarell"] [sansSerif] + ".modal" & + overflowY hidden Media.tablet $ do fontSize (px 15) button ? fontSize (px 15) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 32600d7..272cd39 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -92,18 +92,29 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = +create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment +create userId name cost date frequency = Query (\conn -> do - now <- getCurrentTime + time <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?)" ]) - (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) - SQLite.lastInsertRowId conn + (userId, name, cost, date, FrequencyField frequency, time) + paymentId <- SQLite.lastInsertRowId conn + return $ Payment + { _payment_id = paymentId + , _payment_user = userId + , _payment_name = name + , _payment_cost = cost + , _payment_date = date + , _payment_frequency = frequency + , _payment_createdAt = time + , _payment_editedAt = Nothing + , _payment_deletedAt = Nothing + } ) createMany :: [Payment] -> Query () -- cgit v1.2.3 From 8a28f608d8e08fba4bbe54b46804d261686c3c03 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 20:33:17 +0100 Subject: Upgrade reflex-platform --- server/src/Design/Modal.hs | 2 +- server/src/Design/Views.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 2677fd8..914c011 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -31,7 +31,7 @@ design = do zIndex 1000 backgroundColor white sym borderRadius (px 5) - boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) ".add" ? Add.design ".delete" ? Delete.design diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index a73a1fa..b9e3cf8 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -43,5 +43,5 @@ design = do ".tag" ? do sym borderRadius (px 4) sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + boxShadow . pure . bsColor (rgba 0 0 0 0.3) $ shadowWithBlur (px 2) (px 2) (px 5) color Color.white -- cgit v1.2.3 From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 31 Oct 2018 19:03:19 +0100 Subject: Various fixes --- server/src/Controller/Index.hs | 3 ++- server/src/Design/Global.hs | 14 ++++++++++---- server/src/Design/Helper.hs | 13 +------------ server/src/Design/View/SignIn.hs | 6 ------ 4 files changed, 13 insertions(+), 23 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f942540..0b276d3 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -6,6 +6,7 @@ module Controller.Index ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -60,7 +61,7 @@ askSignIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent + Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail Nothing -> textKey badRequest400 Msg.Secure_Unauthorized else textKey badRequest400 Msg.SignIn_EmailInvalid diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index de8dd61..ba4ccb7 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -73,14 +73,20 @@ global = do svg ? height (pct 100) button ? do - ".content" ? display flex - svg # ".loader" ? display none + position relative + + ".content" ? do + display flex + + svg # ".loader" ? do + opacity 0 + position absolute ".waiting" & do ".content" ? do - display none + opacity 0 svg # ".loader" ? do - display block + opacity 1 rotateKeyframes rotateAnimation diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 6980c71..e586d56 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,16 +1,14 @@ module Design.Helper ( clearFix , button - , input , centeredWithMargin , verticalCentering ) where import Prelude hiding (span) -import Clay hiding (button, input) +import Clay hiding (button) -import Design.Color as Color import Design.Constants clearFix :: Css @@ -37,15 +35,6 @@ button backgroundCol textCol h focusOp = do hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) -input :: Double -> Css -input h = do - height (px h) - padding (px 10) (px 10) (px 10) (px 10) - borderRadius radius radius radius radius - border solid (px 1) Color.dustyGray - focus & borderColor Color.silver - verticalAlign middle - centeredWithMargin :: Css centeredWithMargin = do width (pct blockPercentWidth) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 7f5f503..2138676 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -17,12 +17,6 @@ design = do marginLeft auto marginRight auto - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - button # ".validate" ? do Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten display flex -- cgit v1.2.3 From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- server/src/Controller/Index.hs | 26 +++++++------- server/src/Design/Form.hs | 10 ++++-- server/src/Design/Global.hs | 59 +++++++++++++++++++++++++++----- server/src/Design/Modal.hs | 2 +- server/src/Design/View/Header.hs | 2 ++ server/src/Design/View/Payment/Add.hs | 7 ++-- server/src/Design/View/Payment/Delete.hs | 3 ++ server/src/Validation/Atomic.hs | 2 +- server/src/View/Page.hs | 3 ++ 9 files changed, 85 insertions(+), 29 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 0b276d3..fbda527 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -9,18 +9,18 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as Json 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 (badRequest400, ok200) +import qualified Network.HTTP.Types.Status as Status import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (InitResult (..), SignIn (..), - User (..)) +import Common.Model (Email (..), InitResult (..), + SignInForm (..), User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession @@ -30,7 +30,6 @@ 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 import View.Page (page) @@ -45,10 +44,12 @@ get conf = do 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 +askSignIn :: Conf -> SignInForm -> ActionM () +askSignIn conf form = + case SignInValidation.signIn form of + Nothing -> + textKey Status.badRequest400 Msg.SignIn_EmailInvalid + Just (Email email) -> do maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do @@ -62,9 +63,8 @@ askSignIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid + Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) trySignIn :: Conf -> Text -> ActionM () @@ -116,4 +116,4 @@ getLoggedUser = do liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> S.status ok200 +signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 0385cb4..31a2127 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -22,7 +22,7 @@ design = do ".textInput" ? do position relative - marginBottom (em 1.5) + marginBottom (em 2) paddingTop (px inputTop) marginTop (px (-10)) @@ -46,7 +46,7 @@ design = do position absolute top (px inputTop) left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) + transition "all" (sec 0.2) easeInOut (sec 0) button ? do position absolute @@ -110,11 +110,13 @@ design = do fontWeight bold ".selectInput" ? do - marginBottom (em 1) + marginBottom (em 2) + label ? do display block marginBottom (px 10) fontSize (pct 80) + select ? do width (pct 100) backgroundColor Color.white @@ -122,6 +124,8 @@ design = do sym borderRadius (px 3) sym2 padding (px 5) (px 8) option ? sym2 padding (px 5) (px 8) + focus & backgroundColor Color.wildSand + ".error" & do select ? borderColor Color.chestnutRose ".errorMessage" ? do diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index ba4ccb7..66e9f47 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -3,6 +3,7 @@ module Design.Global ) where import Clay +import Clay.Color as C import Data.Text.Lazy (Text) import qualified Design.Color as Color @@ -26,8 +27,16 @@ global = do Views.design Form.design + spinKeyframes + appearKeyframe + + html ? do + height (pct 100) + body ? do + position relative minWidth (px 320) + height (pct 100) fontFamily ["Cantarell"] [sansSerif] ".modal" & overflowY hidden @@ -40,6 +49,28 @@ global = do button ? fontSize (px 14) input ? fontSize (px 14) + ".app" ? do + appearAnimation + + ".spinner" ? do + display flex + alignItems center + justifyContent center + width (pct 100) + height (pct 100) + paddingBottom (pct 10) + + before & do + display block + content (stringContent "") + width (px 50) + height (px 50) + border solid (px 3) (C.setA 0.3 Color.chestnutRose) + sym borderRadius (pct 50) + borderTopColor Color.chestnutRose + spinKeyframes + spinAnimation + a ? cursor pointer input ? fontSize inherit @@ -87,21 +118,31 @@ global = do opacity 0 svg # ".loader" ? do opacity 1 - rotateKeyframes - rotateAnimation + spinAnimation select ? cursor pointer -rotateAnimation :: Css -rotateAnimation = do +spinAnimation :: Css +spinAnimation = do animationName "rotate" animationDuration (sec 1) - animationTimingFunction easeOut + animationTimingFunction easeInOut animationIterationCount infinite -rotateKeyframes :: Css -rotateKeyframes = keyframes +spinKeyframes :: Css +spinKeyframes = keyframes "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") + [ (100, "transform" -: "rotate(360deg)") + ] + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") ] diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 914c011..9c016b9 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -23,7 +23,7 @@ design = do transition "all" (sec 0.2) ease (sec 0) ".modalContent" ? do - minWidth (px 270) + minWidth (px 300) position fixed top (pct 25) left (pct 50) diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 97f1802..2422686 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -56,6 +56,8 @@ design = do ".signOut" ? do display flex + justifyContent center + alignItems center svg ? do Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs index 199ad36..5ecae7a 100644 --- a/server/src/Design/View/Payment/Add.hs +++ b/server/src/Design/View/Payment/Add.hs @@ -14,12 +14,12 @@ design = do backgroundColor Color.chestnutRose fontSize (px 18) color Color.white - sym padding (px 20) + sym2 padding (px 20) (px 30) textAlign (alignSide sideCenter) borderRadius (px 5) (px 5) (px 0) (px 0) ".addContent" ? do - sym padding (px 20) + sym2 padding (px 20) (px 30) ".buttons" ? do display flex @@ -30,3 +30,6 @@ design = do Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten ".undo" ? Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs index 5597f5b..f3d7e3f 100644 --- a/server/src/Design/View/Payment/Delete.hs +++ b/server/src/Design/View/Payment/Delete.hs @@ -30,3 +30,6 @@ design = do Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten ".undo" ? Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs index d15ad49..7a7351a 100644 --- a/server/src/Validation/Atomic.hs +++ b/server/src/Validation/Atomic.hs @@ -19,7 +19,7 @@ nonNullNumber :: Int -> Maybe Text nonNullNumber n = if n == 0 then Just $ Msg.get Msg.Form_NonNullNumber - else Nothing + else Nothing -- number :: (Int -> Bool) -> Text -> Maybe Int -- number numberForm str = diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 97b84fa..f47c544 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -31,6 +31,9 @@ page initResult = link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign + H.body $ do + H.div ! A.class_ "spinner" $ "" + jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = -- cgit v1.2.3 From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Aug 2019 21:53:30 +0200 Subject: Use updated payment categories from payment add in payment’s table --- server/src/Controller/Payment.hs | 6 ++-- server/src/Persistence/PaymentCategory.hs | 48 ++++++++++++++++++++----------- 2 files changed, 35 insertions(+), 19 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index fb7fcb2..e82fd49 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -10,6 +10,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty import Common.Model (CreatePayment (..), + CreatedPayment (..), EditPayment (..), PaymentId, User (..)) import qualified Model.Query as Query @@ -30,8 +31,9 @@ create createPayment@(CreatePayment name cost date category frequency) = case CreatePaymentValidation.validate createPayment of Nothing -> (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency + pc <- PaymentCategoryPersistence.save name category + p <- PaymentPersistence.create (_user_id user) name cost date frequency + return $ CreatedPayment p pc ) >>= json Just validationError -> do diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 1e377b1..1cfd702 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -4,7 +4,7 @@ module Persistence.PaymentCategory , save ) where -import Data.Maybe (isJust, listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -40,27 +40,41 @@ listByCategory cat = SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) ) -save :: Text -> CategoryId -> Query () +save :: Text -> CategoryId -> Query PaymentCategory save newName categoryId = Query (\conn -> do now <- getCurrentTime - hasPaymentCategory <- isJust <$> listToMaybe <$> + paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [Row]) - if hasPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) + (Only formattedNewName)) + case paymentCategory of + Just pc -> + do + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formattedNewName) + return $ PaymentCategory + (_paymentCategory_id pc) + formattedNewName + categoryId + (_paymentCategory_createdAt pc) + (Just now) + Nothing -> + do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formattedNewName, categoryId, now) + paymentCategoryId <- SQLite.lastInsertRowId conn + return $ PaymentCategory + paymentCategoryId + formattedNewName + categoryId + now + Nothing ) where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower + formattedNewName = T.unaccent . T.toLower $ newName -- cgit v1.2.3 From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 7 Aug 2019 21:27:59 +0200 Subject: Update category according to payment in add overlay --- server/src/Persistence/PaymentCategory.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'server/src') diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 1cfd702..5fd035a 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -6,7 +6,6 @@ module Persistence.PaymentCategory import qualified Data.Maybe as Maybe import Data.Text (Text) -import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -77,4 +76,4 @@ save newName categoryId = Nothing ) where - formattedNewName = T.unaccent . T.toLower $ newName + formattedNewName = T.formatSearch newName -- cgit v1.2.3 From fb8f0fe577e28dae69903413b761da50586e0099 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 14:53:41 +0200 Subject: Remove payment category if unused after a payment is deleted --- server/src/Controller/Income.hs | 33 +++++++++++---------------- server/src/Controller/Payment.hs | 37 +++++++++++++++++++------------ server/src/Main.hs | 8 +++---- server/src/Persistence/Income.hs | 34 ++++++++++------------------ server/src/Persistence/Payment.hs | 34 +++++++++------------------- server/src/Persistence/PaymentCategory.hs | 14 ++++++++++-- 6 files changed, 75 insertions(+), 85 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 3f623e5..ed58ac8 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,17 +1,15 @@ module Controller.Income ( create - , editOwn - , deleteOwn + , edit + , 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 +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty hiding (delete) import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) -import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Query as Query @@ -24,23 +22,18 @@ create (CreateIncome date amount) = (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId ) -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = +edit :: EditIncome -> ActionM () +edit (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount + updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount if updated - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = +delete :: IncomeId -> ActionM () +delete incomeId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted + _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId + status Status.ok200 ) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e82fd49..3d857be 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,18 +1,18 @@ module Controller.Payment ( list , create - , editOwn - , deleteOwn + , edit + , delete ) where import Control.Monad.IO.Class (liftIO) import qualified Network.HTTP.Types.Status as Status -import Web.Scotty +import Web.Scotty hiding (delete) import Common.Model (CreatePayment (..), CreatedPayment (..), - EditPayment (..), PaymentId, - User (..)) + EditPayment (..), Payment (..), + PaymentId, User (..)) import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -41,11 +41,11 @@ create createPayment@(CreatePayment name cost date category frequency) = json validationError ) -editOwn :: EditPayment -> ActionM () -editOwn (EditPayment paymentId name cost date category frequency) = +edit :: EditPayment -> ActionM () +edit (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency + edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategoryPersistence.save name category >> return () else return () @@ -55,11 +55,20 @@ editOwn (EditPayment paymentId name cost date category frequency) = else status Status.badRequest400 ) -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = +delete :: PaymentId -> ActionM () +delete paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId - if deleted - then status Status.ok200 - else status Status.badRequest400 + deleted <- liftIO . Query.run $ do + payment <- PaymentPersistence.find paymentId + case payment of + Just p | _payment_user p == _user_id user -> do + PaymentPersistence.delete (_user_id user) paymentId + PaymentCategoryPersistence.deleteIfUnused (_payment_name p) + return True + _ -> + return False + if deleted then + status Status.ok200 + else + status Status.badRequest400 ) diff --git a/server/src/Main.hs b/server/src/Main.hs index 745071c..0ccf5e2 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -35,21 +35,21 @@ main = do S.jsonData >>= Payment.create S.put "/payment" $ - S.jsonData >>= Payment.editOwn + S.jsonData >>= Payment.edit S.delete "/payment/:id" $ do paymentId <- S.param "id" - Payment.deleteOwn paymentId + Payment.delete paymentId S.post "/income" $ S.jsonData >>= Income.create S.put "/income" $ - S.jsonData >>= Income.editOwn + S.jsonData >>= Income.edit S.delete "/income/:id" $ do incomeId <- S.param "id" - Income.deleteOwn incomeId + Income.delete incomeId S.post "/category" $ S.jsonData >>= Category.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index a863f85..cee9892 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,8 +1,8 @@ module Persistence.Income ( list , create - , editOwn - , deleteOwn + , edit + , delete ) where import Data.Maybe (listToMaybe) @@ -12,7 +12,7 @@ import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) -import Common.Model (Income (..), IncomeId, User (..), +import Common.Model (Income (..), IncomeId, PaymentId, UserId) import Model.Query (Query (Query)) @@ -47,8 +47,8 @@ create incomeUserId incomeDate incomeAmount = SQLite.lastInsertRowId conn ) -editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool -editOwn incomeUserId incomeId incomeDate incomeAmount = +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool +edit incomeUserId incomeId incomeDate incomeAmount = Query (\conn -> do mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) @@ -68,21 +68,11 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = return False ) -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - 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 - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False +delete :: UserId -> PaymentId -> Query () +delete userId paymentId = + Query (\conn -> + SQLite.execute + conn + "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" + (paymentId, userId) ) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 272cd39..3d8f129 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -6,8 +6,8 @@ module Persistence.Payment , listActiveMonthlyOrderedByName , create , createMany - , editOwn - , deleteOwn + , edit + , delete ) where import Data.Maybe (listToMaybe) @@ -129,8 +129,8 @@ createMany payments = (map InsertRow payments) ) -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +edit userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) @@ -158,23 +158,11 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = return False ) -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just (Row payment) -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False +delete :: UserId -> PaymentId -> Query () +delete userId paymentId = + Query (\conn -> + SQLite.execute + conn + "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" + (paymentId, userId) ) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 5fd035a..7dc363c 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -2,16 +2,17 @@ module Persistence.PaymentCategory ( list , listByCategory , save + , deleteIfUnused ) where import qualified Data.Maybe as Maybe import Data.Text (Text) +import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite import Common.Model (CategoryId, PaymentCategory (..)) -import qualified Common.Util.Text as T import Model.Query (Query (Query)) @@ -76,4 +77,13 @@ save newName categoryId = Nothing ) where - formattedNewName = T.formatSearch newName + formattedNewName = T.toLower newName + +deleteIfUnused :: Text -> Query () +deleteIfUnused name = + Query (\conn -> + SQLite.execute + conn + "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)" + (name, name) + ) >> return () -- cgit v1.2.3 From 234b5b29361734656dc780148309962f932d9907 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 15:07:11 +0200 Subject: Use select component in payment search line --- server/src/Design/View/Payment/Header.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 0cb5b5d..9111374 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -59,10 +59,8 @@ design = do marginBottom (em 1) width (pct 100) - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock ".infos" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) -- cgit v1.2.3 From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 21:31:27 +0200 Subject: Add smooth transitions to modal show and hide --- server/src/Design/Form.hs | 33 +-------------------------------- server/src/Design/Global.hs | 7 ++++--- server/src/Design/Modal.hs | 39 ++++++++++++++++++++++++++++++++------- 3 files changed, 37 insertions(+), 42 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 31a2127..0f236f7 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -14,7 +14,6 @@ design = do let inputHeight = 30 let inputTop = 22 let inputPaddingBottom = 3 - let inputZIndex = 1 label ? do cursor pointer @@ -29,9 +28,9 @@ design = do input ? do width (pct 100) position relative - zIndex inputZIndex backgroundColor transparent paddingBottom (px inputPaddingBottom) + paddingRight (px 14) -- Space for the delete icon borderStyle none borderBottom solid (px 1) Color.dustyGray marginBottom (px 5) @@ -52,7 +51,6 @@ design = do position absolute right (px 0) top (px 27) - zIndex inputZIndex svg ? "path" ? ("fill" -: Color.toString Color.silver) hover & svg ? "path" ? @@ -80,35 +78,6 @@ design = do borderColor transparent backgroundColor transparent - ".radioGroup" ? do - position relative - marginBottom (em 2) - - ".title" ? do - color Color.silver - marginBottom (em 0.8) - - ".radioInputs" ? do - display flex - "justify-content" -: "center" - - ".radioInput:not(:last-child)::after" ? do - content (stringContent "/") - marginLeft (px 10) - marginRight (px 10) - - input ? do - opacity 0 - width (px 30) - margin (px 0) (px (-15)) (px 0) (px (-15)) - - "input:focus + label" ? do - textDecoration underline - - "input:checked + label" ? do - color Color.chestnutRose - fontWeight bold - ".selectInput" ? do marginBottom (em 2) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 66e9f47..24d999f 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -22,7 +22,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design - ".modal" ? Modal.design + Modal.design ".tooltip" ? Tooltip.design Views.design Form.design @@ -33,13 +33,14 @@ global = do html ? do height (pct 100) + "g-Body--Modal" ? + overflowY hidden + body ? do position relative minWidth (px 320) height (pct 100) fontFamily ["Cantarell"] [sansSerif] - ".modal" & - overflowY hidden Media.tablet $ do fontSize (px 15) button ? fontSize (px 15) diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 9c016b9..dce2ef9 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -11,24 +11,37 @@ import qualified Design.View.Payment.Delete as Delete design :: Css design = do - ".modalCurtain" ? do + appearKeyframe + + ".g-Modal" ? do + appearAnimation + transition "all" (sec 0.2) ease (sec 0) + display none + opacity 0 + + ".g-Modal--Show" & do + display block + opacity 1 + + ".g-Modal--Hiding" & do + display block + + ".g-Modal__Curtain" ? do position fixed top (px 0) left (px 0) width (pct 100) height (pct 100) - backgroundColor (rgba 0 0 0 0.7) - zIndex 1000 - opacity 1 - transition "all" (sec 0.2) ease (sec 0) + backgroundColor (rgba 0 0 0 0.6) + zIndex 1 - ".modalContent" ? do + ".g-Modal__Content" ? do minWidth (px 300) position fixed top (pct 25) left (pct 50) "transform" -: "translate(-50%, -25%)" - zIndex 1000 + zIndex 1 backgroundColor white sym borderRadius (px 5) boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) @@ -44,3 +57,15 @@ design = do ".deletePaymentModal" <> ".deleteIncomeModal" ? do h1 ? marginBottom (em 1.5) + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.15) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] -- cgit v1.2.3 From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 11 Aug 2019 22:40:09 +0200 Subject: Add payment clone --- server/src/Controller/Payment.hs | 29 ++++++++------- server/src/Design/Modal.hs | 4 ++- server/src/Design/View/Payment/Form.hs | 35 ++++++++++++++++++ server/src/Persistence/Payment.hs | 66 ++++++++++++++++++++++------------ 4 files changed, 98 insertions(+), 36 deletions(-) create mode 100644 server/src/Design/View/Payment/Form.hs (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 3d857be..c700240 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -10,9 +10,9 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreatePayment (..), - CreatedPayment (..), EditPayment (..), Payment (..), - PaymentId, User (..)) + PaymentId, SavedPayment (..), + User (..)) import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -33,7 +33,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do pc <- PaymentCategoryPersistence.save name category p <- PaymentPersistence.create (_user_id user) name cost date frequency - return $ CreatedPayment p pc + return $ SavedPayment p pc ) >>= json Just validationError -> do @@ -44,15 +44,20 @@ create createPayment@(CreatePayment name cost date category frequency) = edit :: EditPayment -> ActionM () edit (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ do - edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - _ <- if edited - then PaymentCategoryPersistence.save name category >> return () - else return () - return edited - if updated - then status Status.ok200 - else status Status.badRequest400 + result <- liftIO . Query.run $ do + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency + case editedPayment of + Just p -> do + pc <- PaymentCategoryPersistence.save name category + PaymentCategoryPersistence.deleteIfUnused name + return $ Just (p, pc) + Nothing -> + return Nothing + case result of + Just (p, pc) -> + json $ SavedPayment p pc + Nothing -> + status Status.badRequest400 ) delete :: PaymentId -> ActionM () diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index dce2ef9..4020eb0 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -7,6 +7,7 @@ import Data.Monoid ((<>)) import qualified Design.View.Payment.Add as Add import qualified Design.View.Payment.Delete as Delete +import qualified Design.View.Payment.Form as Form design :: Css design = do @@ -14,9 +15,9 @@ design = do appearKeyframe ".g-Modal" ? do + display none appearAnimation transition "all" (sec 0.2) ease (sec 0) - display none opacity 0 ".g-Modal--Show" & do @@ -47,6 +48,7 @@ design = do boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) ".add" ? Add.design + ".form" ? Form.design ".delete" ? Delete.design ".paymentModal" & do diff --git a/server/src/Design/View/Payment/Form.hs b/server/src/Design/View/Payment/Form.hs new file mode 100644 index 0000000..aada12b --- /dev/null +++ b/server/src/Design/View/Payment/Form.hs @@ -0,0 +1,35 @@ +module Design.View.Payment.Form + ( 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 + ".formHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym2 padding (px 20) (px 30) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".formContent" ? do + sym2 padding (px 20) (px 30) + + ".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 + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 3d8f129..b3f2b2e 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -129,33 +129,53 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -edit userId paymentId paymentName paymentCost paymentDate paymentFrequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment) +edit userId paymentId name cost date frequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + SQLite.query + conn + "SELECT * FROM payment WHERE id = ? and userId = ?" + (paymentId, userId) case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId) - return True - else - return False + Just payment -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE" + , " payment" + , "SET" + , " edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE" + , " id = ?" + , " AND user_id = ?" + ]) + ( now + , name + , cost + , date + , FrequencyField frequency + , paymentId + , userId + ) + return . Just $ Payment + { _payment_id = paymentId + , _payment_user = userId + , _payment_name = name + , _payment_cost = cost + , _payment_date = date + , _payment_frequency = frequency + , _payment_createdAt = _payment_createdAt payment + , _payment_editedAt = Just now + , _payment_deletedAt = Nothing + } Nothing -> - return False + return Nothing ) delete :: UserId -> PaymentId -> Query () -- cgit v1.2.3 From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:28:54 +0200 Subject: Make payment edition to work on the frontend --- server/src/Controller/Payment.hs | 6 +++--- server/src/Persistence/Payment.hs | 6 +++--- server/src/Persistence/PaymentCategory.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c700240..38c1c19 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -47,10 +47,10 @@ edit (EditPayment paymentId name cost date category frequency) = result <- liftIO . Query.run $ do editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency case editedPayment of - Just p -> do + Just (old, new) -> do pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused name - return $ Just (p, pc) + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return $ Just (new, pc) Nothing -> return Nothing case result of diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index b3f2b2e..bcd7eb8 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -129,13 +129,13 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment) +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment)) edit userId paymentId name cost date frequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> SQLite.query conn - "SELECT * FROM payment WHERE id = ? and userId = ?" + "SELECT * FROM payment WHERE id = ? and user_id = ?" (paymentId, userId) case mbPayment of Just payment -> do @@ -163,7 +163,7 @@ edit userId paymentId name cost date frequency = , paymentId , userId ) - return . Just $ Payment + return . Just . (,) payment $ Payment { _payment_id = paymentId , _payment_user = userId , _payment_name = name diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 7dc363c..46be7f5 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -84,6 +84,6 @@ deleteIfUnused name = Query (\conn -> SQLite.execute conn - "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)" + "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)" (name, name) ) >> return () -- cgit v1.2.3 From 2cbd43c3a0f0640776a4e7c7425b3210d2e6632b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:41:17 +0200 Subject: Make input label clickable again --- server/src/Design/Form.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 0f236f7..506343d 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -15,10 +15,6 @@ design = do let inputTop = 22 let inputPaddingBottom = 3 - label ? do - cursor pointer - color Color.silver - ".textInput" ? do position relative marginBottom (em 2) @@ -40,7 +36,9 @@ design = do borderWidth (px 2) paddingBottom (px $ inputPaddingBottom - 1) - label ? do + ".label" ? do + zIndex (-1) + color Color.silver lineHeight (px inputHeight) position absolute top (px inputTop) @@ -56,7 +54,7 @@ design = do hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25)) - (input # ".filled" |+ label) <> (input # focus |+ label) ? do + (input # ".filled" |+ ".label") <> (input # focus |+ ".label") ? do top (px 0) fontSize (pct 80) @@ -81,7 +79,8 @@ design = do ".selectInput" ? do marginBottom (em 2) - label ? do + ".label" ? do + color Color.silver display block marginBottom (px 10) fontSize (pct 80) -- cgit v1.2.3 From 7529a18ff0ac443e7f9764b5e2d0f57a5d3a850b Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 9 Oct 2019 23:16:00 +0200 Subject: Use common payment validation in the backend Remove deprecated backend validation --- server/src/Controller/Helper.hs | 17 ++++++++ server/src/Controller/Payment.hs | 73 +++++++++++++++++++--------------- server/src/Model/CreatePayment.hs | 16 ++++++++ server/src/Model/EditPayment.hs | 17 ++++++++ server/src/Validation/Atomic.hs | 32 --------------- server/src/Validation/CreatePayment.hs | 25 ------------ server/src/Validation/Payment.hs | 33 +++++++++++++++ 7 files changed, 123 insertions(+), 90 deletions(-) create mode 100644 server/src/Controller/Helper.hs create mode 100644 server/src/Model/CreatePayment.hs create mode 100644 server/src/Model/EditPayment.hs delete mode 100644 server/src/Validation/Atomic.hs delete mode 100644 server/src/Validation/CreatePayment.hs create mode 100644 server/src/Validation/Payment.hs (limited to 'server/src') diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs new file mode 100644 index 0000000..fd0d2bb --- /dev/null +++ b/server/src/Controller/Helper.hs @@ -0,0 +1,17 @@ +module Controller.Helper + ( jsonOrBadRequest + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () +jsonOrBadRequest (Left message) = do + S.status Status.badRequest400 + S.text (LT.fromStrict message) +jsonOrBadRequest (Right a) = + S.json a diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 38c1c19..ba9d1ba 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -6,18 +6,25 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) +import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) -import Common.Model (CreatePayment (..), - EditPayment (..), Payment (..), - PaymentId, SavedPayment (..), - User (..)) +import Common.Model (Category (..), + CreatePaymentForm (..), + EditPaymentForm (..), + Payment (..), PaymentId, + SavedPayment (..), User (..)) +import qualified Common.Msg as Msg +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure -import qualified Validation.CreatePayment as CreatePaymentValidation +import qualified Validation.Payment as PaymentValidation list :: ActionM () list = @@ -25,39 +32,39 @@ list = (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) -create :: CreatePayment -> ActionM () -create createPayment@(CreatePayment name cost date category frequency) = +create :: CreatePaymentForm -> ActionM () +create form = Secure.loggedAction (\user -> - case CreatePaymentValidation.validate createPayment of - Nothing -> - (liftIO . Query.run $ do + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.list + case PaymentValidation.createPayment cs form of + Success (CreatePayment name cost date category frequency) -> do pc <- PaymentCategoryPersistence.save name category p <- PaymentPersistence.create (_user_id user) name cost date frequency - return $ SavedPayment p pc - ) >>= json - Just validationError -> - do - status Status.badRequest400 - json validationError + return . Right $ SavedPayment p pc + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) -edit :: EditPayment -> ActionM () -edit (EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - result <- liftIO . Query.run $ do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return $ Just (new, pc) - Nothing -> - return Nothing - case result of - Just (p, pc) -> - json $ SavedPayment p pc - Nothing -> - status Status.badRequest400 +edit :: EditPaymentForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.list + case PaymentValidation.editPayment cs form of + Success (EditPayment paymentId name cost date category frequency) -> do + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency + case editedPayment of + Just (old, new) -> do + pc <- PaymentCategoryPersistence.save name category + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return . Right $ SavedPayment new pc + Nothing -> + return . Left $ Msg.get Msg.Error_PaymentEdit + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) delete :: PaymentId -> ActionM () diff --git a/server/src/Model/CreatePayment.hs b/server/src/Model/CreatePayment.hs new file mode 100644 index 0000000..b25d2a4 --- /dev/null +++ b/server/src/Model/CreatePayment.hs @@ -0,0 +1,16 @@ +module Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Model/EditPayment.hs b/server/src/Model/EditPayment.hs new file mode 100644 index 0000000..ac4c906 --- /dev/null +++ b/server/src/Model/EditPayment.hs @@ -0,0 +1,17 @@ +module Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency, PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs deleted file mode 100644 index 7a7351a..0000000 --- a/server/src/Validation/Atomic.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Validation.Atomic - ( nonEmpty - , nonNullNumber - -- , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import qualified Common.Msg as Msg - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Just $ Msg.get Msg.Form_NonEmpty - else Nothing - -nonNullNumber :: Int -> Maybe Text -nonNullNumber n = - if n == 0 - then Just $ Msg.get Msg.Form_NonNullNumber - else Nothing - --- number :: (Int -> Bool) -> Text -> Maybe Int --- number numberForm str = --- case reads (T.unpack str) :: [(Int, String)] of --- (num, _) : _ -> --- if numberForm num --- then Just num --- else Nothing --- _ -> --- Nothing diff --git a/server/src/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs deleted file mode 100644 index fbcdb7c..0000000 --- a/server/src/Validation/CreatePayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Validation.CreatePayment - ( validate - ) where - -import Data.Maybe (catMaybes) - -import Common.Model.CreatePayment (CreatePayment (..), - CreatePaymentError (..)) -import qualified Validation.Atomic as Atomic - -validate :: CreatePayment -> Maybe CreatePaymentError -validate p = - if not . null . catMaybes $ [ nameError, costError ] - then Just createPaymentError - else Nothing - where - nameError = Atomic.nonEmpty . _createPayment_name $ p - costError = Atomic.nonNullNumber . _createPayment_cost $ p - createPaymentError = CreatePaymentError - { _createPaymentError_name = nameError - , _createPaymentError_cost = costError - , _createPaymentError_date = Nothing - , _createPaymentError_category = Nothing - , _createPaymentError_frequency = Nothing - } diff --git a/server/src/Validation/Payment.hs b/server/src/Validation/Payment.hs new file mode 100644 index 0000000..20e370e --- /dev/null +++ b/server/src/Validation/Payment.hs @@ -0,0 +1,33 @@ +module Validation.Payment + ( createPayment + , editPayment + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CategoryId, CreatePaymentForm (..), + EditPaymentForm (..)) +import qualified Common.Validation.Payment as PaymentValidation +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) + +createPayment :: [CategoryId] -> CreatePaymentForm -> Validation Text CreatePayment +createPayment categories form = + CreatePayment + <$> PaymentValidation.name (_createPaymentForm_name form) + <*> PaymentValidation.cost (_createPaymentForm_cost form) + <*> PaymentValidation.date (_createPaymentForm_date form) + <*> PaymentValidation.category categories (_createPaymentForm_category form) + <*> V.Success (_createPaymentForm_frequency form) + +editPayment :: [CategoryId] -> EditPaymentForm -> Validation Text EditPayment +editPayment categories form = + EditPayment + <$> V.Success (_editPaymentForm_id form) + <*> PaymentValidation.name (_editPaymentForm_name form) + <*> PaymentValidation.cost (_editPaymentForm_cost form) + <*> PaymentValidation.date (_editPaymentForm_date form) + <*> PaymentValidation.category categories (_editPaymentForm_category form) + <*> V.Success (_editPaymentForm_frequency form) -- cgit v1.2.3 From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- server/src/Controller/Index.hs | 2 +- server/src/Design/View/Header.hs | 7 +++++-- server/src/Design/View/NotFound.hs | 21 +++++++++++++++++++++ server/src/Design/Views.hs | 21 +++++++++++---------- server/src/Main.hs | 36 ++++++++++++++++++++---------------- 5 files changed, 58 insertions(+), 29 deletions(-) create mode 100644 server/src/Design/View/NotFound.hs (limited to 'server/src') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index fbda527..5ebe921 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -57,7 +57,7 @@ askSignIn conf form = let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, - "/signIn/", + "/api/signIn/", token ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 2422686..59e0e51 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -40,8 +40,11 @@ design = do ".current" & backgroundColor (Color.chestnutRose -. 20) Media.mobile $ fontSize (px 13) - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + (".item" # hover) <> (".item" # focus) ? + backgroundColor (Color.chestnutRose +. 10) + + (".item.current" # hover) <> (".item.current" # focus) ? + backgroundColor (Color.chestnutRose -. 10) ".nameSignOut" ? do display flex diff --git a/server/src/Design/View/NotFound.hs b/server/src/Design/View/NotFound.hs new file mode 100644 index 0000000..150c6fc --- /dev/null +++ b/server/src/Design/View/NotFound.hs @@ -0,0 +1,21 @@ +module Design.View.NotFound + ( design + ) where + +import Clay +import Prelude hiding (rem) + +import qualified Design.Color as Color + +design :: Css +design = do + + marginLeft (rem 3) + + ".link" ? do + display block + marginTop (rem 1) + color Color.chestnutRose + textDecoration underline + hover & + color (Color.chestnutRose +. 15) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index b9e3cf8..bf39cff 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,16 +4,16 @@ module Design.Views import Clay -import qualified Design.View.Header as Header -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table design :: Css design = do @@ -21,6 +21,7 @@ design = do ".payment" ? Payment.design ".signIn" ? SignIn.design ".stat" ? Stat.design + ".notfound" ? NotFound.design Table.design ".withMargin" ? do diff --git a/server/src/Main.hs b/server/src/Main.hs index 0ccf5e2..e3dad9e 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -15,48 +15,52 @@ main = do conf <- Conf.get "application.conf" _ <- runDaemons conf S.scotty (Conf.port conf) $ do - S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } - S.middleware . staticPolicy $ noDots >-> addBase "public" - S.get "/" $ do - Index.get conf + S.middleware $ + W.gzip $ W.def { W.gzipFiles = GzipCompress } + + S.middleware . staticPolicy $ + noDots >-> addBase "public" - S.post "/askSignIn" $ do + S.post "/api/askSignIn" $ S.jsonData >>= Index.askSignIn conf - S.get "/signIn/:signInToken" $ do + S.get "/api/signIn/:signInToken" $ do signInToken <- S.param "signInToken" Index.trySignIn conf signInToken - S.post "/signOut" $ + S.post "/api/signOut" $ Index.signOut conf - S.post "/payment" $ + S.post "/api/payment" $ S.jsonData >>= Payment.create - S.put "/payment" $ + S.put "/api/payment" $ S.jsonData >>= Payment.edit - S.delete "/payment/:id" $ do + S.delete "/api/payment/:id" $ do paymentId <- S.param "id" Payment.delete paymentId - S.post "/income" $ + S.post "/api/income" $ S.jsonData >>= Income.create - S.put "/income" $ + S.put "/api/income" $ S.jsonData >>= Income.edit - S.delete "/income/:id" $ do + S.delete "/api/income/:id" $ do incomeId <- S.param "id" Income.delete incomeId - S.post "/category" $ + S.post "/api/category" $ S.jsonData >>= Category.create - S.put "/category" $ + S.put "/api/category" $ S.jsonData >>= Category.edit - S.delete "/category/:id" $ do + S.delete "/api/category/:id" $ do categoryId <- S.param "id" Category.delete categoryId + + S.notFound $ + Index.get conf -- cgit v1.2.3 From 6dfc1c166db387a60630eff980e330518601df5b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 13 Oct 2019 20:58:45 +0200 Subject: Fix sign in responsiveness --- server/src/Design/Global.hs | 6 +++--- server/src/Design/View/SignIn.hs | 4 +++- 2 files changed, 6 insertions(+), 4 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 24d999f..5b8f2dc 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -111,14 +111,14 @@ global = do display flex svg # ".loader" ? do - opacity 0 + display none position absolute ".waiting" & do ".content" ? do - opacity 0 + display none svg # ".loader" ? do - opacity 1 + display block spinAnimation select ? cursor pointer diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 2138676..a39276e 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -4,6 +4,7 @@ module Design.View.SignIn import Clay import Data.Monoid ((<>)) +import Prelude hiding (rem) import qualified Design.Color as Color import qualified Design.Constants as Constants @@ -12,7 +13,8 @@ import qualified Design.Helper as Helper design :: Css design = do let inputHeight = 50 - width (px 500) + maxWidth (px 550) + sym2 padding (rem 0) (rem 2) marginTop (px 100) marginLeft auto marginRight auto -- cgit v1.2.3 From 0b40b6b5583b5c437f83e61bf8913f2b4c447b24 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 19 Oct 2019 09:36:03 +0200 Subject: Include pages into table component --- server/src/Design/View/Pages.hs | 55 +++++++++++++++++++++++++++++++++++++++++ server/src/Design/Views.hs | 2 ++ 2 files changed, 57 insertions(+) create mode 100644 server/src/Design/View/Pages.hs (limited to 'server/src') diff --git a/server/src/Design/View/Pages.hs b/server/src/Design/View/Pages.hs new file mode 100644 index 0000000..1482ef4 --- /dev/null +++ b/server/src/Design/View/Pages.hs @@ -0,0 +1,55 @@ +module Design.View.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = + ".pages" ? do + display flex + justifyContent center + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index bf39cff..73b7240 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -10,6 +10,7 @@ import qualified Design.Helper as Helper import qualified Design.Media as Media import qualified Design.View.Header as Header import qualified Design.View.NotFound as NotFound +import qualified Design.View.Pages as Pages import qualified Design.View.Payment as Payment import qualified Design.View.SignIn as SignIn import qualified Design.View.Stat as Stat @@ -23,6 +24,7 @@ design = do ".stat" ? Stat.design ".notfound" ? NotFound.design Table.design + Pages.design ".withMargin" ? do "margin" -: "0 2vw" -- cgit v1.2.3 From 7aadcc97f9df0e2daccbe8a8726d8bc6c63d67f4 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 12:02:21 +0200 Subject: Add income --- server/src/Controller/Income.hs | 23 +++++++++++++++++------ server/src/Model/CreateIncome.hs | 10 ++++++++++ server/src/Model/EditIncome.hs | 13 +++++++++++++ server/src/Persistence/Income.hs | 19 ++++++++++++++----- server/src/Validation/Income.hs | 27 +++++++++++++++++++++++++++ 5 files changed, 81 insertions(+), 11 deletions(-) create mode 100644 server/src/Model/CreateIncome.hs create mode 100644 server/src/Model/EditIncome.hs create mode 100644 server/src/Validation/Income.hs (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index ed58ac8..e013849 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -5,21 +5,32 @@ module Controller.Income ) where import Control.Monad.IO.Class (liftIO) +import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) -import Common.Model (CreateIncome (..), EditIncome (..), - IncomeId, User (..)) +import Common.Model (CreateIncomeForm (..), + EditIncome (..), IncomeId, + User (..)) -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateIncome (CreateIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence import qualified Secure +import qualified Validation.Income as IncomeValidation -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = +create :: CreateIncomeForm -> ActionM () +create form = Secure.loggedAction (\user -> - (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId + (liftIO . Query.run $ do + case IncomeValidation.createIncome form of + Success (CreateIncome amount date) -> do + Right <$> (IncomePersistence.create (_user_id user) date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) edit :: EditIncome -> ActionM () diff --git a/server/src/Model/CreateIncome.hs b/server/src/Model/CreateIncome.hs new file mode 100644 index 0000000..82451d2 --- /dev/null +++ b/server/src/Model/CreateIncome.hs @@ -0,0 +1,10 @@ +module Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Time.Calendar (Day) + +data CreateIncome = CreateIncome + { _createIncome_amount :: Int + , _createIncome_date :: Day + } deriving (Show) diff --git a/server/src/Model/EditIncome.hs b/server/src/Model/EditIncome.hs new file mode 100644 index 0000000..ac3d311 --- /dev/null +++ b/server/src/Model/EditIncome.hs @@ -0,0 +1,13 @@ +module Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Time.Calendar (Day) + +import Common.Model (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_amount :: Int + , _editIncome_date :: Day + } deriving (Show) diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cee9892..a0c3bbf 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -36,15 +36,24 @@ list = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = +create :: UserId -> Day -> Int -> Query Income +create userId date amount = Query (\conn -> do - now <- getCurrentTime + createdAt <- getCurrentTime SQLite.execute conn "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn + (userId, date, amount, createdAt) + incomeId <- SQLite.lastInsertRowId conn + return $ Income + { _income_id = incomeId + , _income_userId = userId + , _income_date = date + , _income_amount = amount + , _income_createdAt = createdAt + , _income_editedAt = Nothing + , _income_deletedAt = Nothing + } ) edit :: UserId -> IncomeId -> Day -> Int -> Query Bool diff --git a/server/src/Validation/Income.hs b/server/src/Validation/Income.hs new file mode 100644 index 0000000..5e034d1 --- /dev/null +++ b/server/src/Validation/Income.hs @@ -0,0 +1,27 @@ +module Validation.Income + ( createIncome + , editIncome + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..)) +import qualified Common.Validation.Income as IncomeValidation +import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) + +createIncome :: CreateIncomeForm -> Validation Text CreateIncome +createIncome form = + CreateIncome + <$> IncomeValidation.amount (_createIncomeForm_amount form) + <*> IncomeValidation.date (_createIncomeForm_date form) + +editIncome :: EditIncomeForm -> Validation Text EditIncome +editIncome form = + EditIncome + <$> V.Success (_editIncomeForm_id form) + <*> IncomeValidation.amount (_editIncomeForm_amount form) + <*> IncomeValidation.date (_editIncomeForm_date form) -- cgit v1.2.3 From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 21:31:57 +0200 Subject: Load init data per page with AJAX --- server/src/Controller/Category.hs | 9 ++++++++- server/src/Controller/Income.hs | 9 ++++++++- server/src/Controller/Index.hs | 11 ++++++----- server/src/Controller/Payment.hs | 7 +++++++ server/src/Controller/User.hs | 17 +++++++++++++++++ server/src/Design/Global.hs | 12 ++++++++++++ server/src/Main.hs | 24 +++++++++++++++++++++++- server/src/Persistence/Init.hs | 25 ------------------------- 8 files changed, 81 insertions(+), 33 deletions(-) create mode 100644 server/src/Controller/User.hs delete mode 100644 server/src/Persistence/Init.hs (limited to 'server/src') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 37b8357..e536caa 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( create + ( list + , create , edit , delete ) where @@ -19,6 +20,12 @@ import qualified Persistence.Category as CategoryPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ CategoryPersistence.list) >>= json + ) + create :: CreateCategory -> ActionM () create (CreateCategory name color) = Secure.loggedAction (\_ -> diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index e013849..b40976b 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income - ( create + ( list + , create , edit , delete ) where @@ -20,6 +21,12 @@ import qualified Persistence.Income as IncomePersistence import qualified Secure import qualified Validation.Income as IncomeValidation +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ IncomePersistence.list) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 5ebe921..3788685 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -16,8 +16,9 @@ import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), InitResult (..), - SignInForm (..), User (..)) +import Common.Model (Email (..), Init (..), + InitResult (..), SignInForm (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -26,7 +27,6 @@ import Conf (Conf (..)) import qualified LoginSession import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Persistence.Init as InitPersistence import qualified Persistence.User as UserPersistence import qualified Secure import qualified SendMail @@ -40,8 +40,9 @@ get conf = do case mbLoggedUser of Nothing -> return InitEmpty - Just user -> - liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf + Just user -> do + users <- liftIO . Query.run $ UserPersistence.list + return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) S.html $ page initResult askSignIn :: Conf -> SignInForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index ba9d1ba..30b63ff 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment ( list + , listPaymentCategories , create , edit , delete @@ -32,6 +33,12 @@ list = (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +listPaymentCategories :: ActionM () +listPaymentCategories = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json + ) + create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs new file mode 100644 index 0000000..a7bb136 --- /dev/null +++ b/server/src/Controller/User.hs @@ -0,0 +1,17 @@ +module Controller.User + ( list + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ UserPersistence.list) >>= S.json + ) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 5b8f2dc..598319b 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -52,6 +52,18 @@ global = do ".app" ? do appearAnimation + display flex + height (pct 100) + flexDirection column + + "main" ? + appearAnimation + + ".pageSpinner" ? do + display flex + alignItems center + justifyContent center + flexGrow 1 ".spinner" ? do display flex diff --git a/server/src/Main.hs b/server/src/Main.hs index e3dad9e..9882092 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,3 +1,8 @@ +module Main + ( main + ) where + +import qualified Network.HTTP.Types.Status as Status import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static @@ -8,6 +13,7 @@ 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.User as User import Job.Daemon (runDaemons) main :: IO () @@ -32,6 +38,12 @@ main = do S.post "/api/signOut" $ Index.signOut conf + S.get "/api/users"$ + User.list + + S.get "/api/payments" $ + Payment.list + S.post "/api/payment" $ S.jsonData >>= Payment.create @@ -42,6 +54,9 @@ main = do paymentId <- S.param "id" Payment.delete paymentId + S.get "/api/incomes" $ + Income.list + S.post "/api/income" $ S.jsonData >>= Income.create @@ -52,6 +67,12 @@ main = do incomeId <- S.param "id" Income.delete incomeId + S.get "/api/paymentCategories" $ + Payment.listPaymentCategories + + S.get "/api/categories" $ + Category.list + S.post "/api/category" $ S.jsonData >>= Category.create @@ -62,5 +83,6 @@ main = do categoryId <- S.param "id" Category.delete categoryId - S.notFound $ + S.notFound $ do + S.status Status.ok200 Index.get conf diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs deleted file mode 100644 index 74d9172..0000000 --- a/server/src/Persistence/Init.hs +++ /dev/null @@ -1,25 +0,0 @@ -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) -- cgit v1.2.3 From 61ff1443c42def5a09f624e3df2e2520e97610d0 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 23:25:05 +0200 Subject: Clone incomes --- server/src/Design/View/Payment/Table.hs | 5 ----- server/src/Design/View/Table.hs | 3 +++ 2 files changed, 3 insertions(+), 5 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index 26dc9ed..67828c9 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -4,7 +4,6 @@ module Design.View.Payment.Table import Clay -import qualified Design.Color as Color import qualified Design.Media as Media design :: Css @@ -34,7 +33,3 @@ design = do ".shortDate" ? display none ".longDate" ? display inline marginBottom (em 0.5) - - ".button" & svg ? do - "path" ? ("fill" -: Color.toString Color.chestnutRose) - width (px 18) diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index cd406fc..1c4e806 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -72,6 +72,9 @@ design = do textAlign (alignSide sideCenter) button ? do padding (px 10) (px 10) (px 10) (px 10) + svg ? do + "path" ? ("fill" -: Color.toString Color.chestnutRose) + width (px 18) hover & "svg path" ? do "fill" -: "rgb(237, 122, 116)" -- cgit v1.2.3 From f968c8ce63e1aec119b1e6f414cf27e2c0294bcb Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 21:09:54 +0200 Subject: Delete income --- server/src/Design/View/ConfirmDialog.hs | 36 +++++++++++++++++++++++++++++++++ server/src/Design/Views.hs | 24 ++++++++++++---------- 2 files changed, 49 insertions(+), 11 deletions(-) create mode 100644 server/src/Design/View/ConfirmDialog.hs (limited to 'server/src') diff --git a/server/src/Design/View/ConfirmDialog.hs b/server/src/Design/View/ConfirmDialog.hs new file mode 100644 index 0000000..410d4d8 --- /dev/null +++ b/server/src/Design/View/ConfirmDialog.hs @@ -0,0 +1,36 @@ +module Design.View.ConfirmDialog + ( 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 + ".confirm" ? do + ".confirmHeader" ? 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) + + ".confirmContent" ? 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 + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 73b7240..5c9e307 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,17 +4,18 @@ module Design.Views import Clay -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media -import qualified Design.View.Header as Header -import qualified Design.View.NotFound as NotFound -import qualified Design.View.Pages as Pages -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.ConfirmDialog as ConfirmDialog +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Pages as Pages +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table design :: Css design = do @@ -25,6 +26,7 @@ design = do ".notfound" ? NotFound.design Table.design Pages.design + ConfirmDialog.design ".withMargin" ? do "margin" -: "0 2vw" -- cgit v1.2.3 From e4b32ce15f8c92f3b477d3f3d4d301ba08f9b5e3 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:35:27 +0200 Subject: Edit an income --- server/src/Controller/Income.hs | 21 +++++++++++++-------- server/src/Persistence/Income.hs | 31 ++++++++++++++++++------------- 2 files changed, 31 insertions(+), 21 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index b40976b..236e032 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -11,11 +11,12 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncome (..), IncomeId, + EditIncomeForm (..), IncomeId, User (..)) import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence import qualified Secure @@ -40,13 +41,17 @@ create form = ) >>= ControllerHelper.jsonOrBadRequest ) -edit :: EditIncome -> ActionM () -edit (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount - if updated - then status Status.ok200 - else status Status.badRequest400 +edit :: EditIncomeForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.editIncome form of + Success (EditIncome incomeId amount date) -> do + Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) delete :: IncomeId -> ActionM () diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index a0c3bbf..2b9bf0c 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -56,25 +56,30 @@ create userId date amount = } ) -edit :: UserId -> IncomeId -> Day -> Int -> Query Bool -edit incomeUserId incomeId incomeDate incomeAmount = +edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) +edit userId incomeId incomeDate incomeAmount = Query (\conn -> do 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 - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False + do + currentTime <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" + (currentTime, incomeDate, incomeAmount, incomeId, userId) + return . Just $ Income + { _income_id = incomeId + , _income_userId = userId + , _income_date = incomeDate + , _income_amount = incomeAmount + , _income_createdAt = _income_createdAt income + , _income_editedAt = Just currentTime + , _income_deletedAt = Nothing + } Nothing -> - return False + return Nothing ) delete :: UserId -> PaymentId -> Query () -- cgit v1.2.3 From 62f990c92b51aeca44d50c154cb4a18e2da3637c Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:45:02 +0200 Subject: Disable appear animation on main block --- server/src/Design/Global.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'server/src') diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 598319b..f9884bd 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -56,8 +56,8 @@ global = do height (pct 100) flexDirection column - "main" ? - appearAnimation + -- "main" ? + -- appearAnimation ".pageSpinner" ? do display flex -- cgit v1.2.3 From b97ad942495352c3fc1e0c820cfba82a9693ac7a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 27 Oct 2019 20:26:29 +0100 Subject: WIP Set up server side paging for incomes --- server/src/Controller/Income.hs | 13 ++++++++++++- server/src/Main.hs | 5 +++++ server/src/Persistence/Income.hs | 26 +++++++++++++++++++++++++- 3 files changed, 42 insertions(+), 2 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 236e032..3272cbf 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income ( list + , listv2 , create , edit , delete @@ -12,7 +13,7 @@ import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeId, - User (..)) + IncomesAndCount (..), User (..)) import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -28,6 +29,16 @@ list = (liftIO . Query.run $ IncomePersistence.list) >>= json ) +listv2 :: Int -> Int -> ActionM () +listv2 page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- IncomePersistence.count + incomes <- IncomePersistence.listv2 page perPage + return $ IncomesAndCount incomes count + ) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Main.hs b/server/src/Main.hs index 9882092..00e8d1c 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -54,6 +54,11 @@ main = do paymentId <- S.param "id" Payment.delete paymentId + S.get "/api/v2/incomes" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Income.listv2 page perPage + S.get "/api/incomes" $ Income.list diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 2b9bf0c..de55a18 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,5 +1,7 @@ module Persistence.Income - ( list + ( count + , list + , listv2 , create , edit , delete @@ -29,6 +31,18 @@ instance FromRow Row where SQLite.field <*> SQLite.field) +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" + ) + list :: Query [Income] list = Query (\conn -> @@ -36,6 +50,16 @@ list = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) +listv2 :: Int -> Int -> Query [Income] +listv2 page perPage = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do -- cgit v1.2.3 From a267f0bb4566389342c3244d3c082dc2453f4615 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 09:22:12 +0100 Subject: Show users in income table --- server/src/Design/Appearing.hs | 25 +++++++++++++++++++++++++ server/src/Design/Global.hs | 2 ++ 2 files changed, 27 insertions(+) create mode 100644 server/src/Design/Appearing.hs (limited to 'server/src') diff --git a/server/src/Design/Appearing.hs b/server/src/Design/Appearing.hs new file mode 100644 index 0000000..79b94b3 --- /dev/null +++ b/server/src/Design/Appearing.hs @@ -0,0 +1,25 @@ +module Design.Appearing + ( design + ) where + +import Clay + +design :: Css +design = do + + appearKeyframe + + ".g-Appearing" ? do + appearAnimation + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index f9884bd..df41cfd 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -6,6 +6,7 @@ import Clay import Clay.Color as C import Data.Text.Lazy (Text) +import qualified Design.Appearing as Appearing import qualified Design.Color as Color import qualified Design.Constants as Constants import qualified Design.Errors as Errors @@ -22,6 +23,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design + Appearing.design Modal.design ".tooltip" ? Tooltip.design Views.design -- cgit v1.2.3 From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:28:42 +0100 Subject: Show income header --- server/src/Controller/Income.hs | 49 ++++++++++++++++++++++++++++------------ server/src/Job/WeeklyReport.hs | 2 +- server/src/Main.hs | 7 ++---- server/src/Persistence/Income.hs | 23 +++++++++++-------- 4 files changed, 50 insertions(+), 31 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 3272cbf..d8d3d89 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,42 +1,61 @@ module Controller.Income ( list - , listv2 , create , edit , delete ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), IncomeId, - IncomesAndCount (..), User (..)) + EditIncomeForm (..), Income (..), + IncomeHeader (..), IncomeId, + IncomePage (..), User (..)) +import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure import qualified Validation.Income as IncomeValidation -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.list) >>= json - ) - -listv2 :: Int -> Int -> ActionM () -listv2 page perPage = - Secure.loggedAction (\_ -> +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do count <- IncomePersistence.count - incomes <- IncomePersistence.listv2 page perPage - return $ IncomesAndCount incomes count - ) >>= json + + users <- UserPersistence.list + allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all + allIncomes <- IncomePersistence.listAll + + let since = + CM.useIncomesFrom (map _user_id users) allIncomes allPayments + + let byUser = + case since of + Just s -> + M.fromList . flip map users $ \user -> + ( _user_id user + , CM.cumulativeIncomesSince currentTime s $ + filter ((==) (_user_id user) . _income_userId) allIncomes + ) + + Nothing -> + M.empty + + incomes <- IncomePersistence.list page perPage + return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 203c4e8..1a478dc 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list + (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.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 00e8d1c..40b53b6 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -54,13 +54,10 @@ main = do paymentId <- S.param "id" Payment.delete paymentId - S.get "/api/v2/incomes" $ do + S.get "/api/incomes" $ do page <- S.param "page" perPage <- S.param "perPage" - Income.listv2 page perPage - - S.get "/api/incomes" $ - Income.list + Income.list page perPage S.post "/api/income" $ S.jsonData >>= Income.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index de55a18..4ae3228 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,7 +1,7 @@ module Persistence.Income ( count , list - , listv2 + , listAll , create , edit , delete @@ -43,15 +43,8 @@ count = SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" ) -list :: Query [Income] -list = - Query (\conn -> - map (\(Row i) -> i) <$> - SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" - ) - -listv2 :: Int -> Int -> Query [Income] -listv2 page perPage = +list :: Int -> Int -> Query [Income] +list page perPage = Query (\conn -> map (\(Row i) -> i) <$> SQLite.query @@ -60,6 +53,16 @@ listv2 page perPage = (perPage, (page - 1) * perPage) ) +listAll :: Query [Income] +listAll = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" + ) + +-- firstIncomeByUser +-- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id; + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do -- cgit v1.2.3 From 182f3d3fea9985c0e403087fe253981c68e57102 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:33:20 +0100 Subject: Fix payment page --- server/src/Controller/Income.hs | 7 +++++++ server/src/Main.hs | 3 +++ 2 files changed, 10 insertions(+) (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index d8d3d89..4a41bd3 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income ( list + , deprecatedList , create , edit , delete @@ -58,6 +59,12 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) +deprecatedList :: ActionM () +deprecatedList = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ IncomePersistence.listAll) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Main.hs b/server/src/Main.hs index 40b53b6..b2672e4 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -59,6 +59,9 @@ main = do perPage <- S.param "perPage" Income.list page perPage + S.get "/api/deprecated/incomes" $ do + Income.deprecatedList + S.post "/api/income" $ S.jsonData >>= Income.create -- cgit v1.2.3 From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 15:47:11 +0100 Subject: Fetch the first payment date instead of every payment to get cumulative income --- server/src/Controller/Income.hs | 4 ++-- server/src/Persistence/Payment.hs | 16 ++++++++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 4a41bd3..127e3b3 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -37,11 +37,11 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all + firstPayment <- PaymentPersistence.firstPunctualDay allIncomes <- IncomePersistence.listAll let since = - CM.useIncomesFrom (map _user_id users) allIncomes allPayments + CM.useIncomesFrom (map _user_id users) allIncomes firstPayment let byUser = case since of diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index bcd7eb8..eb238d4 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,6 +1,7 @@ module Persistence.Payment ( Payment(..) , find + , firstPunctualDay , listActive , listPunctual , listActiveMonthlyOrderedByName @@ -60,6 +61,21 @@ find paymentId = SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) ) +data DayRow = DayRow Day + +instance FromRow DayRow where + fromRow = DayRow <$> SQLite.field + +firstPunctualDay :: Query (Maybe Day) +firstPunctualDay = + Query (\conn -> do + fmap (\(DayRow d) -> d) . listToMaybe <$> + SQLite.query + conn + "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1" + (Only (FrequencyField Punctual)) + ) + listActive :: Query [Payment] listActive = Query (\conn -> do -- cgit v1.2.3 From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 6 Nov 2019 19:44:15 +0100 Subject: Show the payment table with server side paging --- server/src/Controller/Payment.hs | 19 ++++++++++++++++--- server/src/Design/View/Header.hs | 1 - server/src/Design/View/SignIn.hs | 2 +- server/src/Design/View/Table.hs | 11 +++++++++++ server/src/Main.hs | 9 +++++++-- server/src/Persistence/Income.hs | 3 --- server/src/Persistence/Payment.hs | 25 ++++++++++++++++++++++++- 7 files changed, 59 insertions(+), 11 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 30b63ff..01702cb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment - ( list + ( deprecatedList + , list , listPaymentCategories , create , edit @@ -15,6 +16,7 @@ import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), Payment (..), PaymentId, + PaymentPage (..), SavedPayment (..), User (..)) import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper @@ -27,12 +29,23 @@ import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure import qualified Validation.Payment as PaymentValidation -list :: ActionM () -list = +deprecatedList :: ActionM () +deprecatedList = Secure.loggedAction (\_ -> (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- PaymentPersistence.count + payments <- PaymentPersistence.listActivePage page perPage + paymentCategories <- PaymentCategoryPersistence.list + return $ PaymentPage payments paymentCategories count + ) >>= json + ) + listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 59e0e51..609d8fc 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -25,7 +25,6 @@ design = do ".title" <> ".item" ? headerPadding ".title" ? do - height (pct 100) textAlign (alignSide sideLeft) Media.mobile $ fontSize (px 22) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index a39276e..42c9621 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -13,7 +13,7 @@ import qualified Design.Helper as Helper design :: Css design = do let inputHeight = 50 - maxWidth (px 550) + width (px 350) sym2 padding (rem 0) (rem 2) marginTop (px 100) marginLeft auto diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index 1c4e806..c77cb7c 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -67,6 +67,17 @@ design = do ".refund" & color Color.mossGreen + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + ".cell.button" & do position relative textAlign (alignSide sideCenter) diff --git a/server/src/Main.hs b/server/src/Main.hs index b2672e4..a4d8635 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -41,8 +41,13 @@ main = do S.get "/api/users"$ User.list - S.get "/api/payments" $ - Payment.list + S.get "/api/deprecated/payments" $ + Payment.deprecatedList + + S.get "/api/payments" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Payment.list page perPage S.post "/api/payment" $ S.jsonData >>= Payment.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 4ae3228..cb2ef10 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -60,9 +60,6 @@ listAll = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) --- firstIncomeByUser --- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id; - create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index eb238d4..e01753f 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,8 +1,9 @@ module Persistence.Payment - ( Payment(..) + ( count , find , firstPunctualDay , listActive + , listActivePage , listPunctual , listActiveMonthlyOrderedByName , create @@ -54,6 +55,18 @@ instance ToRow InsertRow where , toField (_payment_createdAt p) ] +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL" + ) + find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do @@ -83,6 +96,16 @@ listActive = SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" ) +listActivePage :: Int -> Int -> Query [Payment] +listActivePage page perPage = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.query + conn + "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + listPunctual :: Query [Payment] listPunctual = Query (\conn -> do -- cgit v1.2.3 From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 7 Nov 2019 07:59:41 +0100 Subject: Show payment header infos --- server/src/Controller/Payment.hs | 54 ++++++++++++++++++++++---------- server/src/Design/Modal.hs | 8 ++--- server/src/Design/View/Payment.hs | 6 +--- server/src/Design/View/Payment/Delete.hs | 35 --------------------- server/src/Design/View/Payment/Header.hs | 45 +++++++++++--------------- server/src/Design/View/Payment/Pages.hs | 54 -------------------------------- server/src/Design/View/Payment/Table.hs | 35 --------------------- server/src/Design/Views.hs | 2 +- server/src/Main.hs | 3 -- server/src/Persistence/Payment.hs | 21 ++++++++++--- server/src/Util/List.hs | 13 ++++++++ 11 files changed, 88 insertions(+), 188 deletions(-) delete mode 100644 server/src/Design/View/Payment/Delete.hs delete mode 100644 server/src/Design/View/Payment/Pages.hs delete mode 100644 server/src/Design/View/Payment/Table.hs create mode 100644 server/src/Util/List.hs (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 01702cb..f685f2e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,6 +1,5 @@ module Controller.Payment - ( deprecatedList - , list + ( list , listPaymentCategories , create , edit @@ -8,48 +7,69 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status -import Web.Scotty hiding (delete) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), - Payment (..), PaymentId, - PaymentPage (..), + Frequency (Punctual), + Payment (..), PaymentHeader (..), + PaymentId, PaymentPage (..), SavedPayment (..), User (..)) +import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreatePayment (CreatePayment (..)) import Model.EditPayment (EditPayment (..)) import qualified Model.Query as 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 import qualified Secure +import qualified Util.List as L import qualified Validation.Payment as PaymentValidation -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentPersistence.listActive) >>= json - ) - list :: Int -> Int -> ActionM () list page perPage = - Secure.loggedAction (\_ -> + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do count <- PaymentPersistence.count payments <- PaymentPersistence.listActivePage page perPage paymentCategories <- PaymentCategoryPersistence.list - return $ PaymentPage payments paymentCategories count - ) >>= json + + users <- UserPersistence.list + incomes <- IncomePersistence.listAll + allPayments <- PaymentPersistence.listActive Punctual + + let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + + repartition = + M.fromList + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ allPayments + + header = PaymentHeader + { _paymentHeader_exceedingPayers = exceedingPayers + , _paymentHeader_repartition = repartition + } + + return $ PaymentPage header payments paymentCategories count) >>= S.json ) listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json + (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -100,7 +120,7 @@ delete paymentId = _ -> return False if deleted then - status Status.ok200 + S.status Status.ok200 else - status Status.badRequest400 + S.status Status.badRequest400 ) diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 4020eb0..1195e10 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -3,11 +3,9 @@ module Design.Modal ) where import Clay -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import qualified Design.View.Payment.Add as Add -import qualified Design.View.Payment.Delete as Delete -import qualified Design.View.Payment.Form as Form +import qualified Design.View.Payment.Form as Form design :: Css design = do @@ -47,9 +45,7 @@ design = do sym borderRadius (px 5) boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) - ".add" ? Add.design ".form" ? Form.design - ".delete" ? Delete.design ".paymentModal" & do ".radioGroup" ? ".title" ? display none diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 0d59fa0..27b4ef3 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -5,11 +5,7 @@ module Design.View.Payment import Clay import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Pages as Pages -import qualified Design.View.Payment.Table as Table design :: Css design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design + ".g-HeaderInfos" ? Header.design diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs deleted file mode 100644 index f3d7e3f..0000000 --- a/server/src/Design/View/Payment/Delete.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.View.Payment.Delete - ( 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 - ".deleteHeader" ? 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) - - ".deleteContent" ? 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 - - (".confirm" <> ".undo") ? - width (px 90) diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 9111374..49c1a09 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -8,45 +8,36 @@ import Clay import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Helper as Helper import qualified Design.Media as Media design :: Css design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) marginLeft (pct Constants.blockPercentMargin) marginRight (pct Constants.blockPercentMargin) - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex + ".g-HeaderInfos__ExceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) marginBottom (em 1) - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) + Media.mobile $ do + textAlign (alignSide sideCenter) - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) + ".userName" ? marginRight (px 8) - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) + -- ".addPayment" ? do + -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + -- Media.mobile $ width (pct 100) - ".searchLine" ? do + ".g-HeaderForm" ? do marginBottom (em 1) Media.mobile $ textAlign (alignSide sideCenter) @@ -62,7 +53,7 @@ design = do ".selectInput" ? do Media.tabletDesktop $ display inlineBlock - ".infos" ? do + ".g-HeaderInfos__Repartition" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) Media.mobile $ lineHeight (px 25) diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs deleted file mode 100644 index 2028c1b..0000000 --- a/server/src/Design/View/Payment/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Design.View.Payment.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media - -design :: Css -design = do - display flex - justifyContent center - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs deleted file mode 100644 index 67828c9..0000000 --- a/server/src/Design/View/Payment/Table.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.View.Payment.Table - ( design - ) where - -import Clay - -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 5c9e307..d36a728 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -20,7 +20,7 @@ import qualified Design.View.Table as Table design :: Css design = do header ? Header.design - ".payment" ? Payment.design + Payment.design ".signIn" ? SignIn.design ".stat" ? Stat.design ".notfound" ? NotFound.design diff --git a/server/src/Main.hs b/server/src/Main.hs index a4d8635..5068d10 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -41,9 +41,6 @@ main = do S.get "/api/users"$ User.list - S.get "/api/deprecated/payments" $ - Payment.deprecatedList - S.get "/api/payments" $ do page <- S.param "page" perPage <- S.param "perPage" diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index e01753f..7835c98 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -89,11 +89,14 @@ firstPunctualDay = (Only (FrequencyField Punctual)) ) -listActive :: Query [Payment] -listActive = +listActive :: Frequency -> Query [Payment] +listActive frequency = Query (\conn -> do map (\(Row p) -> p) <$> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + SQLite.query + conn + "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?" + (Only (FrequencyField frequency)) ) listActivePage :: Int -> Int -> Query [Payment] @@ -102,8 +105,16 @@ listActivePage page perPage = map (\(Row p) -> p) <$> SQLite.query conn - "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" - (perPage, (page - 1) * perPage) + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY date DESC" + , "LIMIT ?" + , "OFFSET ?" + ] + ) + (FrequencyField Punctual, perPage, (page - 1) * perPage) ) listPunctual :: Query [Payment] diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs new file mode 100644 index 0000000..4e22ba8 --- /dev/null +++ b/server/src/Util/List.hs @@ -0,0 +1,13 @@ +module Util.List + ( groupBy + ) where + +import Control.Arrow ((&&&)) +import Data.Function (on) +import qualified Data.List as L + +groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] +groupBy f = + map (f . head &&& id) + . L.groupBy ((==) `on` f) + . L.sortBy (compare `on` f) -- cgit v1.2.3 From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 18:08:28 +0100 Subject: Optimize and refactor payments --- server/src/Controller/Category.hs | 27 ++-- server/src/Controller/Income.hs | 17 +- server/src/Controller/Payment.hs | 137 ++++++++--------- server/src/Design/Form.hs | 1 - server/src/Design/View/Payment.hs | 6 +- server/src/Design/View/Payment/Header.hs | 68 -------- server/src/Design/View/Payment/HeaderForm.hs | 40 +++++ server/src/Design/View/Payment/HeaderInfos.hs | 50 ++++++ server/src/Job/WeeklyReport.hs | 23 ++- server/src/Main.hs | 14 +- server/src/Model/SignIn.hs | 4 +- server/src/Payer.hs | 170 ++++++++++++++++++++ server/src/Persistence/Category.hs | 10 +- server/src/Persistence/Income.hs | 59 ++++++- server/src/Persistence/Payment.hs | 214 +++++++++++++++++++------- server/src/Persistence/PaymentCategory.hs | 89 ----------- server/src/Persistence/User.hs | 4 +- server/src/Util/List.hs | 13 -- server/src/View/Mail/WeeklyReport.hs | 22 +-- 19 files changed, 602 insertions(+), 366 deletions(-) delete mode 100644 server/src/Design/View/Payment/Header.hs create mode 100644 server/src/Design/View/Payment/HeaderForm.hs create mode 100644 server/src/Design/View/Payment/HeaderInfos.hs create mode 100644 server/src/Payer.hs delete mode 100644 server/src/Persistence/PaymentCategory.hs delete mode 100644 server/src/Util/List.hs (limited to 'server/src') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index e536caa..8fbc8c8 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -5,19 +5,18 @@ 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.Query as Query -import qualified Persistence.Category as CategoryPersistence -import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import Json (jsonId) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Secure list :: ActionM () @@ -45,10 +44,8 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId - if null paymentCategories - then CategoryPersistence.delete categoryId - else return False + -- TODO: delete only if no payment has this category + CategoryPersistence.delete categoryId if deleted then status ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 127e3b3..75d0133 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,6 +1,5 @@ module Controller.Income ( list - , deprecatedList , create , edit , delete @@ -17,12 +16,12 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), Income (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) -import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query +import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -37,18 +36,18 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - firstPayment <- PaymentPersistence.firstPunctualDay - allIncomes <- IncomePersistence.listAll + paymentRange <- PaymentPersistence.getRange + allIncomes <- IncomePersistence.listAll -- TODO optimize let since = - CM.useIncomesFrom (map _user_id users) allIncomes firstPayment + Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) let byUser = case since of Just s -> M.fromList . flip map users $ \user -> ( _user_id user - , CM.cumulativeIncomesSince currentTime s $ + , Payer.cumulativeIncomesSince currentTime s $ filter ((==) (_user_id user) . _income_userId) allIncomes ) @@ -59,12 +58,6 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.listAll) >>= json - ) - create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index f685f2e..d4d086e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,75 +1,70 @@ module Controller.Payment ( list - , listPaymentCategories , create , edit , delete + , searchCategory ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) -import qualified Network.HTTP.Types.Status as Status -import Web.Scotty (ActionM) -import qualified Web.Scotty as S +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation (Failure, Success)) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (Category (..), - CreatePaymentForm (..), - EditPaymentForm (..), - Frequency (Punctual), - Payment (..), PaymentHeader (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Controller.Helper as ControllerHelper -import Model.CreatePayment (CreatePayment (..)) -import Model.EditPayment (EditPayment (..)) -import qualified Model.Query as 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 +import Common.Model (Category (..), CreatePaymentForm (..), + EditPaymentForm (..), Frequency, + PaymentHeader (..), PaymentId, + PaymentPage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) +import qualified Model.Query as Query +import qualified Payer as Payer +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Util.List as L -import qualified Validation.Payment as PaymentValidation +import qualified Validation.Payment as PaymentValidation -list :: Int -> Int -> ActionM () -list page perPage = +list :: Frequency -> Int -> Int -> Text -> ActionM () +list frequency page perPage search = Secure.loggedAction (\_ -> do currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do - count <- PaymentPersistence.count - payments <- PaymentPersistence.listActivePage page perPage - paymentCategories <- PaymentCategoryPersistence.list + count <- PaymentPersistence.count frequency search + payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll - allPayments <- PaymentPersistence.listActive Punctual + incomes <- IncomePersistence.listAll -- TODO optimize + + paymentRange <- PaymentPersistence.getRange + + searchRepartition <- + case paymentRange of + Just (from, to) -> + PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to) + Nothing -> + return M.empty - let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - repartition = - M.fromList - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ allPayments + let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers - , _paymentHeader_repartition = repartition + , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage header payments paymentCategories count) >>= S.json - ) - -listPaymentCategories :: ActionM () -listPaymentCategories = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json + return $ PaymentPage page header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -78,10 +73,8 @@ create form = (liftIO . Query.run $ do cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.createPayment cs form of - Success (CreatePayment name cost date category frequency) -> do - pc <- PaymentCategoryPersistence.save name category - p <- PaymentPersistence.create (_user_id user) name cost date frequency - return . Right $ SavedPayment p pc + Success (CreatePayment name cost date category frequency) -> + Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -94,14 +87,11 @@ edit form = cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return . Right $ SavedPayment new pc - Nothing -> - return . Left $ Msg.get Msg.Error_PaymentEdit + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + if Maybe.isJust editedPayment then + return . Right $ editedPayment + else + return . Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -109,18 +99,13 @@ edit form = delete :: PaymentId -> ActionM () delete paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ do - payment <- PaymentPersistence.find paymentId - case payment of - Just p | _payment_user p == _user_id user -> do - PaymentPersistence.delete (_user_id user) paymentId - PaymentCategoryPersistence.deleteIfUnused (_payment_name p) - return True - _ -> - return False - if deleted then - S.status Status.ok200 - else - S.status Status.badRequest400 + Secure.loggedAction (\user -> + liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId + ) + +searchCategory :: Text -> ActionM () +searchCategory paymentName = + Secure.loggedAction (\_ -> do + (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) + >>= S.json ) diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 506343d..5713bfe 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -77,7 +77,6 @@ design = do backgroundColor transparent ".selectInput" ? do - marginBottom (em 2) ".label" ? do color Color.silver diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 27b4ef3..d563f5d 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,8 +4,10 @@ module Design.View.Payment import Clay -import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.HeaderForm as HeaderForm +import qualified Design.View.Payment.HeaderInfos as HeaderInfos design :: Css design = do - ".g-HeaderInfos" ? Header.design + HeaderForm.design + HeaderInfos.design diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs deleted file mode 100644 index 49c1a09..0000000 --- a/server/src/Design/View/Payment/Header.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Design.View.Payment.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 2) - Media.mobileTablet $ marginBottom (em 1) - marginLeft (pct Constants.blockPercentMargin) - marginRight (pct Constants.blockPercentMargin) - - ".g-HeaderInfos__ExceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - marginBottom (em 1) - - Media.mobile $ do - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - -- ".addPayment" ? do - -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - -- Media.mobile $ width (pct 100) - - ".g-HeaderForm" ? do - marginBottom (em 1) - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".selectInput" ? do - Media.tabletDesktop $ display inlineBlock - - ".g-HeaderInfos__Repartition" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/Payment/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..6081443 --- /dev/null +++ b/server/src/Design/View/Payment/HeaderForm.hs @@ -0,0 +1,40 @@ +module Design.View.Payment.HeaderForm + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderForm" ? do + marginBottom (em 2) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + display flex + justifyContent spaceBetween + alignItems center + Media.mobile $ flexDirection column + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock + Media.mobile $ marginBottom (em 2) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + flexShrink 0 diff --git a/server/src/Design/View/Payment/HeaderInfos.hs b/server/src/Design/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..acb393b --- /dev/null +++ b/server/src/Design/View/Payment/HeaderInfos.hs @@ -0,0 +1,50 @@ +module Design.View.Payment.HeaderInfos + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderInfos" ? do + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + + ".g-PaymentHeaderInfos__ExceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + marginBottom (em 1) + + Media.mobile $ do + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".g-PaymentHeaderInfos__Repartition" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 1a478dc..34bbd3a 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -15,11 +15,26 @@ import qualified View.Mail.WeeklyReport as WeeklyReport weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime weeklyReport conf mbLastExecution = do now <- getCurrentTime + case mbLastExecution of - Nothing -> return () + Nothing -> + return () + Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list - _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) + (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + users <- UserPersistence.list + paymentRange <- PaymentPersistence.getRange + weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekIncomes <- IncomePersistence.listModifiedSince lastExecution + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + + _ <- + SendMail.sendMail + conf + (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + return () + return now diff --git a/server/src/Main.hs b/server/src/Main.hs index 5068d10..f4d75a0 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -42,9 +42,15 @@ main = do User.list S.get "/api/payments" $ do + frequency <- S.param "frequency" page <- S.param "page" perPage <- S.param "perPage" - Payment.list page perPage + search <- S.param "search" + Payment.list (read frequency) page perPage search + + S.get "/api/payment/category" $ do + name <- S.param "name" + Payment.searchCategory name S.post "/api/payment" $ S.jsonData >>= Payment.create @@ -61,9 +67,6 @@ main = do perPage <- S.param "perPage" Income.list page perPage - S.get "/api/deprecated/incomes" $ do - Income.deprecatedList - S.post "/api/income" $ S.jsonData >>= Income.create @@ -74,9 +77,6 @@ main = do incomeId <- S.param "id" Income.delete incomeId - S.get "/api/paymentCategories" $ - Payment.listPaymentCategories - S.get "/api/categories" $ Category.list diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index 0cc4a03..bcdce61 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -7,7 +7,7 @@ module Model.SignIn ) where import Data.Int (Int64) -import Data.Maybe (listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (UTCTime) @@ -47,7 +47,7 @@ createSignInToken signInEmail = getSignIn :: Text -> Query (Maybe SignIn) getSignIn signInToken = Query (\conn -> do - listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) + Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) ) signInTokenToUsed :: SignInId -> Query () diff --git a/server/src/Payer.hs b/server/src/Payer.hs new file mode 100644 index 0000000..d913afe --- /dev/null +++ b/server/src/Payer.hs @@ -0,0 +1,170 @@ +module Payer + ( getExceedingPayers + , useIncomesFrom + , cumulativeIncomesSince + ) where + +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time +import Data.Time.Calendar (Day) + +import Common.Model (ExceedingPayer (..), Income (..), + User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] +getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = + let userIds = map _user_id users + payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers + mbSince = useIncomesFrom userIds incomes firstPayment + in case mbSince of + Just since -> + let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day +useIncomesFrom userIds incomes firstPayment = + case (firstPayment, incomeDefinedForAll userIds incomes) of + (Just d1, Just d2) -> Just (max d1 d2) + _ -> Nothing + +dayUTCTime :: Day -> UTCTime +dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) + +getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds incomes preIncomeRepartition postIncomeRepartition = + flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition + , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition + , _payer_incomes = filter ((==) userId . _income_userId) incomes + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = cumulativeIncome + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds + firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes + in if all Maybe.isJust firstIncomes + then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: Day -> [Income] -> [Income] +getOrderedIncomesSince since incomes = + let mbStarterIncome = getIncomeAt since incomes + orderedIncomesSince = filter (\income -> _income_date income >= since) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: Day -> [Income] -> Maybe Income +getIncomeAt day incomes = + case incomes of + [x] -> + if _income_date x < day + then Just $ x { _income_date = day } + else Nothing + x1 : x2 : xs -> + if _income_date x1 < day && _income_date x2 >= day + then Just $ x1 { _income_date = day } + else getIncomeAt day (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = dayUTCTime . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 2afe5db..00cf0a5 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -5,7 +5,7 @@ module Persistence.Category , delete ) where -import Data.Maybe (isJust, listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) @@ -48,9 +48,9 @@ create categoryName categoryColor = edit :: CategoryId -> Text -> Text -> Query Bool edit categoryId categoryName categoryColor = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if isJust mbCategory + if Maybe.isJust mbCategory then do now <- getCurrentTime SQLite.execute @@ -65,9 +65,9 @@ edit categoryId categoryName categoryColor = delete :: CategoryId -> Query Bool delete categoryId = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if isJust mbCategory + if Maybe.isJust mbCategory then do now <- getCurrentTime SQLite.execute diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cb2ef10..ba7ad19 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -2,17 +2,22 @@ module Persistence.Income ( count , list , listAll + , listModifiedSince , create , edit , delete + , definedForAll ) where -import Data.Maybe (listToMaybe) +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import qualified Data.Text as T import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) 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 Prelude hiding (id, until) import Common.Model (Income (..), IncomeId, PaymentId, UserId) @@ -31,15 +36,15 @@ instance FromRow Row where SQLite.field <*> SQLite.field) -data Count = Count Int +data CountRow = CountRow Int -instance FromRow Count where - fromRow = Count <$> SQLite.field +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field count :: Query Int count = Query (\conn -> - (\[Count n] -> n) <$> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" ) @@ -60,6 +65,23 @@ listAll = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) +listModifiedSince :: UTCTime -> Query [Income] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM income" + , "WHERE" + , "created_at >= ?" + , "OR edited_at >= ?" + , "OR deleted_at >= ?" + ]) + (Only since) + ) + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do @@ -83,7 +105,7 @@ create userId date amount = edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) edit userId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> + mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> @@ -114,3 +136,26 @@ delete userId paymentId = "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" (paymentId, userId) ) + +data UserDayRow = UserDayRow (UserId, Day) + +instance FromRow UserDayRow where + fromRow = do + user <- SQLite.field + day <- SQLite.field + return $ UserDayRow (user, day) + +definedForAll :: [UserId] -> Query (Maybe Day) +definedForAll users = + Query (\conn -> + (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$> + SQLite.query_ + conn + "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;" + ) + where + fromRows rows = + if L.sort users == L.sort (map fst rows) then + Maybe.listToMaybe . L.sort . map snd $ rows + else + Nothing diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 7835c98..f75925d 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,33 +1,57 @@ module Persistence.Payment ( count , find - , firstPunctualDay - , listActive + , getRange , listActivePage - , listPunctual + , listModifiedSince , listActiveMonthlyOrderedByName , create , createMany , edit , delete + , searchCategory + , repartition + , getPreAndPostPaymentRepartition ) where -import Data.Maybe (listToMaybe) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only), ToRow) import qualified Database.SQLite.Simple as SQLite import Database.SQLite.Simple.ToField (ToField (toField)) -import Prelude hiding (id) +import Prelude hiding (id, until) -import Common.Model (Frequency (..), Payment (..), - PaymentId, UserId) +import Common.Model (CategoryId, Frequency (..), + Payment (..), PaymentId, + User (..), UserId) import Model.Query (Query (Query)) import Persistence.Frequency (FrequencyField (..)) +import qualified Persistence.Income as IncomePersistence + + + +fields :: Text +fields = T.intercalate "," $ + [ "id" + , "user_id" + , "name" + , "cost" + , "date" + , "category" + , "frequency" + , "created_at" + , "edited_at" + , "deleted_at" + ] newtype Row = Row Payment @@ -38,6 +62,7 @@ instance FromRow Row where SQLite.field <*> SQLite.field <*> SQLite.field <*> + SQLite.field <*> (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> SQLite.field <*> SQLite.field <*> @@ -51,6 +76,7 @@ instance ToRow InsertRow where , toField (_payment_name p) , toField (_payment_cost p) , toField (_payment_date p) + , toField (_payment_category p) , toField (FrequencyField (_payment_frequency p)) , toField (_payment_createdAt p) ] @@ -60,73 +86,94 @@ data Count = Count Int instance FromRow Count where fromRow = Count <$> SQLite.field -count :: Query Int -count = +count :: Frequency -> Text -> Query Int +count frequency search = Query (\conn -> (\[Count n] -> n) <$> - SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL" + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT COUNT(*)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" + ]) + (FrequencyField frequency, "%" <> search <> "%") ) find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do - fmap (\(Row p) -> p) . listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.query + conn + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?") + (Only paymentId) ) -data DayRow = DayRow Day +data RangeRow = RangeRow (Day, Day) -instance FromRow DayRow where - fromRow = DayRow <$> SQLite.field +instance FromRow RangeRow where + fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field -firstPunctualDay :: Query (Maybe Day) -firstPunctualDay = +getRange :: Query (Maybe (Day, Day)) +getRange = Query (\conn -> do - fmap (\(DayRow d) -> d) . listToMaybe <$> + fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1" + (SQLite.Query $ T.intercalate " " + [ "SELECT MIN(date), MAX(date)" + , "FROM payment" + , "WHERE" + , "frequency = ?" + , "AND deleted_at IS NULL" + ]) (Only (FrequencyField Punctual)) ) -listActive :: Frequency -> Query [Payment] -listActive frequency = - Query (\conn -> do - map (\(Row p) -> p) <$> - SQLite.query - conn - "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?" - (Only (FrequencyField frequency)) - ) - -listActivePage :: Int -> Int -> Query [Payment] -listActivePage page perPage = +listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] +listActivePage frequency page perPage search = Query (\conn -> map (\(Row p) -> p) <$> SQLite.query conn (SQLite.Query $ T.intercalate " " - [ "SELECT *" + [ "SELECT" + , fields , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" , "ORDER BY date DESC" , "LIMIT ?" , "OFFSET ?" ] ) - (FrequencyField Punctual, perPage, (page - 1) * perPage) + (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage) ) -listPunctual :: Query [Payment] -listPunctual = - Query (\conn -> do - map (\(Row p) -> p) <$> +listModifiedSince :: UTCTime -> Query [Payment] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> SQLite.query conn - (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") - (Only (FrequencyField Punctual)) + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM payment" + , "WHERE" + , "created_at >= ?" + , "OR edited_at >= ?" + , "OR deleted_at >= ?" + ]) + (Only since) ) + listActiveMonthlyOrderedByName :: Query [Payment] listActiveMonthlyOrderedByName = Query (\conn -> do @@ -134,7 +181,8 @@ listActiveMonthlyOrderedByName = SQLite.query conn (SQLite.Query $ T.intercalate " " - [ "SELECT *" + [ "SELECT" + , fields , "FROM payment" , "WHERE deleted_at IS NULL AND frequency = ?" , "ORDER BY name DESC" @@ -142,17 +190,17 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment -create userId name cost date frequency = +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment +create userId name cost date category frequency = Query (\conn -> do time <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) - (userId, name, cost, date, FrequencyField frequency, time) + (userId, name, cost, date, category, FrequencyField frequency, time) paymentId <- SQLite.lastInsertRowId conn return $ Payment { _payment_id = paymentId @@ -160,6 +208,7 @@ create userId name cost date frequency = , _payment_name = name , _payment_cost = cost , _payment_date = date + , _payment_category = category , _payment_frequency = frequency , _payment_createdAt = time , _payment_editedAt = Nothing @@ -173,19 +222,19 @@ createMany payments = SQLite.executeMany conn (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment)) -edit userId paymentId name cost date frequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment) +edit userId paymentId name cost date category frequency = Query (\conn -> do - mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> + mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT * FROM payment WHERE id = ? and user_id = ?" + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") (paymentId, userId) case mbPayment of Just payment -> do @@ -200,6 +249,7 @@ edit userId paymentId name cost date frequency = , " name = ?," , " cost = ?," , " date = ?," + , " category = ?," , " frequency = ?" , "WHERE" , " id = ?" @@ -209,16 +259,18 @@ edit userId paymentId name cost date frequency = , name , cost , date + , category , FrequencyField frequency , paymentId , userId ) - return . Just . (,) payment $ Payment + return . Just $ Payment { _payment_id = paymentId , _payment_user = userId , _payment_name = name , _payment_cost = cost , _payment_date = date + , _payment_category = category , _payment_frequency = frequency , _payment_createdAt = _payment_createdAt payment , _payment_editedAt = Just now @@ -236,3 +288,59 @@ delete userId paymentId = "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" (paymentId, userId) ) + +data CategoryIdRow = CategoryIdRow CategoryId + +instance FromRow CategoryIdRow where + fromRow = CategoryIdRow <$> SQLite.field + +searchCategory :: Text -> Query (Maybe CategoryId) +searchCategory paymentName = + Query (\conn -> + fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> + SQLite.query + conn + "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (Only $ "%" <> paymentName <> "%") + ) + +data UserCostRow = UserCostRow (UserId, Int) + +instance FromRow UserCostRow where + fromRow = do + user <- SQLite.field + cost <- SQLite.field + return $ UserCostRow (user, cost) + +repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) +repartition frequency search from to = + Query (\conn -> + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT user_id, SUM(cost)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" + , "AND date >= ?" + , "AND date < ?" + , "GROUP BY user_id" + ]) + (FrequencyField frequency, "%" <> search <> "%", from, to) + ) + +getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) +getPreAndPostPaymentRepartition paymentRange users = do + case paymentRange of + Just (from, to) -> do + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + (,) + <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll)) + <*> (case incomeDefinedForAll of + Just d -> repartition Punctual "" d (Calendar.addDays 1 to) + Nothing -> return M.empty) + + Nothing -> + return (M.empty, M.empty) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs deleted file mode 100644 index 46be7f5..0000000 --- a/server/src/Persistence/PaymentCategory.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Persistence.PaymentCategory - ( list - , listByCategory - , save - , deleteIfUnused - ) where - -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory (..)) - -import Model.Query (Query (Query)) - -newtype Row = Row PaymentCategory - -instance FromRow Row where - fromRow = Row <$> (PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field) - -list :: Query [PaymentCategory] -list = - Query (\conn -> do - map (\(Row pc) -> pc) <$> - SQLite.query_ conn "SELECT * from payment_category" - ) - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> do - map (\(Row pc) -> pc) <$> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query PaymentCategory -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only formattedNewName)) - case paymentCategory of - Just pc -> - do - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formattedNewName) - return $ PaymentCategory - (_paymentCategory_id pc) - formattedNewName - categoryId - (_paymentCategory_createdAt pc) - (Just now) - Nothing -> - do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formattedNewName, categoryId, now) - paymentCategoryId <- SQLite.lastInsertRowId conn - return $ PaymentCategory - paymentCategoryId - formattedNewName - categoryId - now - Nothing - ) - where - formattedNewName = T.toLower newName - -deleteIfUnused :: Text -> Query () -deleteIfUnused name = - Query (\conn -> - SQLite.execute - conn - "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)" - (name, name) - ) >> return () diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 4ec2dcf..3c3a2b1 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -3,7 +3,7 @@ module Persistence.User , get ) where -import Data.Maybe (listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -32,6 +32,6 @@ list = get :: Text -> Query (Maybe User) get userEmail = Query (\conn -> do - fmap (\(Row u) -> u) . listToMaybe <$> + fmap (\(Row u) -> u) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs deleted file mode 100644 index 4e22ba8..0000000 --- a/server/src/Util/List.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Util.List - ( groupBy - ) where - -import Control.Arrow ((&&&)) -import Data.Function (on) -import qualified Data.List as L - -groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] -groupBy f = - map (f . head &&& id) - . L.groupBy ((==) `on` f) - . L.sortBy (compare `on` f) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 7e88d98..1f637bc 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,6 +9,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Common.Model (ExceedingPayer (..), Income (..), @@ -23,10 +24,11 @@ import Model.IncomeResource (IncomeResource (..)) import Model.Mail (Mail (Mail)) import qualified Model.Mail as M import Model.PaymentResource (PaymentResource (..)) +import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = +mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail +mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -35,24 +37,24 @@ mail conf users payments incomes start end = , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users payments incomes start end + , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end } -body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text -body conf users payments incomes start end = +body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text +body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments) + [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where - paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text -exceedingPayers conf time users incomes payments = +exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text +exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = T.intercalate "\n" . map formatPayer $ payers where - payers = CM.getExceedingPayers time users incomes payments + payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users -- cgit v1.2.3 From 3c67fcf1d524811a18f0c4db3ef6eed1270b9a12 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 19:55:22 +0100 Subject: Hide date from monthly payments --- server/src/Controller/Payment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index d4d086e..c860810 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -64,7 +64,7 @@ list frequency page perPage search = , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage page header payments count) >>= S.json + return $ PaymentPage page frequency header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () -- cgit v1.2.3 From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Nov 2019 16:19:53 +0100 Subject: Compute cumulative income with a DB query --- server/src/Controller/Income.hs | 28 +++----- server/src/Controller/Payment.hs | 16 +++-- server/src/Design/Global.hs | 6 +- server/src/Design/Loadable.hs | 29 ++++++++ server/src/Design/View/Table.hs | 3 + server/src/Design/Views.hs | 16 +++-- server/src/Job/WeeklyReport.hs | 17 ++++- server/src/Payer.hs | 135 +++++++---------------------------- server/src/Persistence/Income.hs | 58 ++++++++++++--- server/src/Persistence/Payment.hs | 12 +++- server/src/View/Mail/WeeklyReport.hs | 21 +++--- 11 files changed, 173 insertions(+), 168 deletions(-) create mode 100644 server/src/Design/Loadable.hs (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 75d0133..784a2db 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -13,7 +13,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), Income (..), + EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) @@ -21,7 +21,6 @@ import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query -import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -36,26 +35,19 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - paymentRange <- PaymentPersistence.getRange - allIncomes <- IncomePersistence.listAll -- TODO optimize - - let since = - Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) + let userIds = _user_id <$> users - let byUser = - case since of - Just s -> - M.fromList . flip map users $ \user -> - ( _user_id user - , Payer.cumulativeIncomesSince currentTime s $ - filter ((==) (_user_id user) . _income_userId) allIncomes - ) + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll - Nothing -> - M.empty + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty incomes <- IncomePersistence.list page perPage - return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c860810..42a4436 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -11,7 +11,6 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import Web.Scotty (ActionM) import qualified Web.Scotty as S @@ -36,16 +35,23 @@ import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () list frequency page perPage search = - Secure.loggedAction (\_ -> do - currentTime <- liftIO Clock.getCurrentTime + Secure.loggedAction (\_ -> (liftIO . Query.run $ do count <- PaymentPersistence.count frequency search payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll -- TODO optimize paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty searchRepartition <- case paymentRange of @@ -57,7 +63,7 @@ list frequency page perPage search = (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index df41cfd..ebd7084 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -12,6 +12,7 @@ import qualified Design.Constants as Constants import qualified Design.Errors as Errors import qualified Design.Form as Form import qualified Design.Helper as Helper +import qualified Design.Loadable as Loadable import qualified Design.Media as Media import qualified Design.Modal as Modal import qualified Design.Tooltip as Tooltip @@ -28,6 +29,7 @@ global = do ".tooltip" ? Tooltip.design Views.design Form.design + Loadable.design spinKeyframes appearKeyframe @@ -92,14 +94,14 @@ global = do h1 ? do color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) + lineHeight (em 1.3) Media.desktop $ fontSize (px 24) Media.tablet $ fontSize (px 22) Media.mobile $ fontSize (px 20) ul ? do + "margin-top" -: "1vh" "margin-bottom" -: "3vh" "margin-left" -: "1vh" li do - (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do users <- UserPersistence.list paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty weekPayments <- PaymentPersistence.listModifiedSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) _ <- SendMail.sendMail conf - (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) return () diff --git a/server/src/Payer.hs b/server/src/Payer.hs index d913afe..ab8312e 100644 --- a/server/src/Payer.hs +++ b/server/src/Payer.hs @@ -1,25 +1,17 @@ module Payer ( getExceedingPayers - , useIncomesFrom - , cumulativeIncomesSince ) where -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time -import Data.Time.Calendar (Day) +import Data.Map (Map) +import qualified Data.Map as M -import Common.Model (ExceedingPayer (..), Income (..), - User (..), UserId) +import Common.Model (ExceedingPayer (..), User (..), UserId) data Payer = Payer { _payer_userId :: UserId , _payer_preIncomePayments :: Int , _payer_postIncomePayments :: Int - , _payer_incomes :: [Income] + , _payer_income :: Int } data PostPaymentPayer = PostPaymentPayer @@ -29,43 +21,29 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] -getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = +getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer] +getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition = let userIds = map _user_id users - payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - mbSince = useIncomesFrom userIds incomes firstPayment - in case mbSince of - Just since -> - let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day -useIncomesFrom userIds incomes firstPayment = - case (firstPayment, incomeDefinedForAll userIds incomes) of - (Just d1, Just d2) -> Just (max d1 d2) - _ -> Nothing - -dayUTCTime :: Day -> UTCTime -dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) - -getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer] -getPayers userIds incomes preIncomeRepartition postIncomeRepartition = + payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition + postPaymentPayers = map getPostPaymentPayer payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersFromAmounts + . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) + $ payers + +getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition = flip map userIds (\userId -> Payer { _payer_userId = userId , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition - , _payer_incomes = filter ((==) userId . _income_userId) incomes + , _payer_income = M.findWithDefault 0 userId cumulativeIncome } ) @@ -85,15 +63,14 @@ exceedingPayersFromAmounts userAmounts = $ userAmounts where mbMinAmount = safeMinimum . map snd $ userAmounts -getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = +getPostPaymentPayer :: Payer -> PostPaymentPayer +getPostPaymentPayer payer = PostPaymentPayer { _postPaymentPayer_userId = _payer_userId payer , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer - , _postPaymentPayer_cumulativeIncome = cumulativeIncome - , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + , _postPaymentPayer_cumulativeIncome = _payer_income payer + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer) } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) getFinalDiff :: Float -> PostPaymentPayer -> Int getFinalDiff maxRatio payer = @@ -101,66 +78,6 @@ getFinalDiff maxRatio payer = truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) in postIncomeDiff + _postPaymentPayer_preIncomePayments payer -incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes - in if all Maybe.isJust firstIncomes - then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: Day -> [Income] -> [Income] -getOrderedIncomesSince since incomes = - let mbStarterIncome = getIncomeAt since incomes - orderedIncomesSince = filter (\income -> _income_date income >= since) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: Day -> [Income] -> Maybe Income -getIncomeAt day incomes = - case incomes of - [x] -> - if _income_date x < day - then Just $ x { _income_date = day } - else Nothing - x1 : x2 : xs -> - if _income_date x1 < day && _income_date x2 >= day - then Just $ x1 { _income_date = day } - else getIncomeAt day (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = dayUTCTime . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - safeMinimum :: (Ord a) => [a] -> Maybe a safeMinimum [] = Nothing safeMinimum xs = Just . minimum $ xs diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index ba7ad19..e689505 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,21 +1,24 @@ module Persistence.Income ( count , list - , listAll , listModifiedSince , create , edit , delete , definedForAll + , getCumulativeIncome ) where import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M import qualified Data.Maybe as Maybe import qualified Data.Text as T import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)), + Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id, until) @@ -58,13 +61,6 @@ list page perPage = (perPage, (page - 1) * perPage) ) -listAll :: Query [Income] -listAll = - Query (\conn -> - map (\(Row i) -> i) <$> - SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" - ) - listModifiedSince :: UTCTime -> Query [Income] listModifiedSince since = Query (\conn -> @@ -79,7 +75,7 @@ listModifiedSince since = , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) create :: UserId -> Day -> Int -> Query Income @@ -156,6 +152,46 @@ definedForAll users = where fromRows rows = if L.sort users == L.sort (map fst rows) then - Maybe.listToMaybe . L.sort . map snd $ rows + Maybe.listToMaybe . reverse . L.sort . map snd $ rows else Nothing + +getCumulativeIncome :: Day -> Day -> Query (Map UserId Int) +getCumulativeIncome start end = + Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters) + where + query = + T.intercalate "\n" $ + [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM (" + , " SELECT" + , " I1.user_id," + , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count" + , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1" + , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2" + , " ON I2.date > I1.date AND I2.user_id == I1.user_id" + , " GROUP BY I1.date, I1.user_id" + , ") GROUP BY user_id" + ] + + selectBoundedIncomes op param = + T.intercalate "\n" $ + [ " SELECT user_id, date, amount FROM (" + , " SELECT" + , " i.user_id, " <> param <> " AS date, i.amount" + , " FROM" + , " (SELECT id, MAX(date) AS max_date" + , " FROM income" + , " WHERE date <= " <> param <> " AND deleted_at IS NULL" + , " GROUP BY user_id) AS m" + , " INNER JOIN income AS i" + , " ON i.id = m.id AND i.date = m.max_date" + , " ) UNION" + , " SELECT user_id, date, amount" + , " FROM income" + , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL" + ] + + parameters = + [ ":start" := start + , ":end" := end + ] diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index f75925d..953f0ae 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -163,14 +163,14 @@ listModifiedSince since = SQLite.query conn (SQLite.Query . T.intercalate " " $ - [ "SELECT *" + [ "SELECT " <> fields , "FROM payment" , "WHERE" , "created_at >= ?" , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) @@ -300,7 +300,13 @@ searchCategory paymentName = fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (SQLite.Query . T.intercalate " " $ + [ "SELECT category" + , "FROM payment" + , "WHERE deleted_at is NULL AND name LIKE ?" + , "ORDER BY edited_at, created_at" + , "LIMIT 1" + ]) (Only $ "%" <> paymentName <> "%") ) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 1f637bc..3fe224f 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,7 +9,6 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Common.Model (ExceedingPayer (..), Income (..), @@ -27,8 +26,8 @@ import Model.PaymentResource (PaymentResource (..)) import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = +mail :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -37,24 +36,24 @@ mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPay , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end } -body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text -body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments - incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text -exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = T.intercalate "\n" . map formatPayer $ payers where - payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users -- cgit v1.2.3 From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 8 Dec 2019 11:39:37 +0100 Subject: Add category page --- server/src/Controller/Category.hs | 66 ++++++++++++++++++++++++++++---------- server/src/Controller/Helper.hs | 11 +++---- server/src/Controller/Income.hs | 16 ++++++--- server/src/Controller/Payment.hs | 17 +++++----- server/src/Json.hs | 16 --------- server/src/Main.hs | 9 ++++-- server/src/Model/CreateCategory.hs | 10 ++++++ server/src/Model/EditCategory.hs | 13 ++++++++ server/src/Persistence/Category.hs | 34 +++++++++++++++++--- server/src/Persistence/Income.hs | 45 ++++++++------------------ server/src/Persistence/Payment.hs | 48 +++++++-------------------- server/src/Validation/Category.hs | 27 ++++++++++++++++ 12 files changed, 184 insertions(+), 128 deletions(-) delete mode 100644 server/src/Json.hs create mode 100644 server/src/Model/CreateCategory.hs create mode 100644 server/src/Model/EditCategory.hs create mode 100644 server/src/Validation/Category.hs (limited to 'server/src') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 8fbc8c8..36ce3fc 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( list + ( listAll + , list , create , edit , delete @@ -7,37 +8,68 @@ module Controller.Category import Control.Monad.IO.Class (liftIO) import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) +import Common.Model (CategoryId, CategoryPage (..), + CreateCategoryForm (..), + EditCategoryForm (..)) import qualified Common.Msg as Msg -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence import qualified Secure +import qualified Validation.Category as CategoryValidation -list :: ActionM () -list = +listAll :: ActionM () +listAll = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.list) >>= json + (liftIO . Query.run $ CategoryPersistence.listAll) >>= json ) -create :: CreateCategory -> ActionM () -create (CreateCategory name color) = +list :: Int -> Int -> ActionM () +list page perPage = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId + (liftIO . Query.run $ do + categories <- CategoryPersistence.list page perPage + count <- CategoryPersistence.count + return $ CategoryPage page categories count + ) >>= json ) -edit :: EditCategory -> ActionM () -edit (EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color - if updated - then status ok200 - else status badRequest400 +create :: CreateCategoryForm -> ActionM () +create form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.createCategory form of + Success (CreateCategory name color) -> do + Right <$> (CategoryPersistence.create name color) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditCategoryForm -> ActionM () +edit form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.editCategory form of + Success (EditCategory categoryId name color) -> + do + isSuccess <- CategoryPersistence.edit categoryId name color + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_CategoryEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest ) delete :: CategoryId -> ActionM () diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs index fd0d2bb..dc9cbc4 100644 --- a/server/src/Controller/Helper.hs +++ b/server/src/Controller/Helper.hs @@ -1,17 +1,16 @@ module Controller.Helper - ( jsonOrBadRequest + ( okOrBadRequest ) where -import Data.Aeson (ToJSON) import Data.Text (Text) import qualified Data.Text.Lazy as LT import qualified Network.HTTP.Types.Status as Status import Web.Scotty (ActionM) import qualified Web.Scotty as S -jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () -jsonOrBadRequest (Left message) = do +okOrBadRequest :: Either Text () -> ActionM () +okOrBadRequest (Left message) = do S.status Status.badRequest400 S.text (LT.fromStrict message) -jsonOrBadRequest (Right a) = - S.json a +okOrBadRequest (Right ()) = + S.status Status.ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 784a2db..96ccbbc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -8,7 +8,7 @@ module Controller.Income import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) @@ -16,6 +16,7 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) +import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -60,7 +61,7 @@ create form = Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditIncomeForm -> ActionM () @@ -68,12 +69,17 @@ edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do case IncomeValidation.editIncome form of - Success (EditIncome incomeId amount date) -> do - Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + Success (EditIncome incomeId amount date) -> + do + isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_IncomeEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: IncomeId -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 42a4436..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -8,7 +8,6 @@ module Controller.Payment import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M -import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar import Data.Validation (Validation (Failure, Success)) @@ -77,30 +76,30 @@ create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.createPayment cs form of Success (CreatePayment name cost date category frequency) -> Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditPaymentForm -> ActionM () edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency - if Maybe.isJust editedPayment then - return . Right $ editedPayment + isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + return $ if isSuccess then + Right () else - return . Left $ Msg.get Msg.Error_PaymentEdit + Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: PaymentId -> ActionM () diff --git a/server/src/Json.hs b/server/src/Json.hs deleted file mode 100644 index 6d40305..0000000 --- a/server/src/Json.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Json - ( jsonObject - , jsonId - ) where - -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Data.Int (Int64) -import Data.Text (Text) -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/server/src/Main.hs b/server/src/Main.hs index f4d75a0..0b80de0 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -77,8 +77,13 @@ main = do incomeId <- S.param "id" Income.delete incomeId - S.get "/api/categories" $ - Category.list + S.get "/api/allCategories" $ do + Category.listAll + + S.get "/api/categories" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Category.list page perPage S.post "/api/category" $ S.jsonData >>= Category.create diff --git a/server/src/Model/CreateCategory.hs b/server/src/Model/CreateCategory.hs new file mode 100644 index 0000000..dae061b --- /dev/null +++ b/server/src/Model/CreateCategory.hs @@ -0,0 +1,10 @@ +module Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Text (Text) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/EditCategory.hs b/server/src/Model/EditCategory.hs new file mode 100644 index 0000000..8ee26ac --- /dev/null +++ b/server/src/Model/EditCategory.hs @@ -0,0 +1,13 @@ +module Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Text (Text) + +import Common.Model (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show) diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 00cf0a5..2934b28 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -1,5 +1,7 @@ module Persistence.Category - ( list + ( count + , list + , listAll , create , edit , delete @@ -27,14 +29,37 @@ instance FromRow Row where SQLite.field <*> SQLite.field) -list :: Query [Category] -list = +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM category WHERE deleted_at IS NULL" + ) + + +list :: Int -> Int -> Query [Category] +list page perPage = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query + conn + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + +listAll :: Query [Category] +listAll = Query (\conn -> map (\(Row c) -> c) <$> SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" ) -create :: Text -> Text -> Query CategoryId +create :: Text -> Text -> Query () create categoryName categoryColor = Query (\conn -> do now <- getCurrentTime @@ -42,7 +67,6 @@ create categoryName categoryColor = conn "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn ) edit :: CategoryId -> Text -> Text -> Query Bool diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index e689505..cd98814 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -78,7 +78,7 @@ listModifiedSince since = (since, since, since) ) -create :: UserId -> Day -> Int -> Query Income +create :: UserId -> Day -> Int -> Query () create userId date amount = Query (\conn -> do createdAt <- getCurrentTime @@ -86,42 +86,23 @@ create userId date amount = conn "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" (userId, date, amount, createdAt) - incomeId <- SQLite.lastInsertRowId conn - return $ Income - { _income_id = incomeId - , _income_userId = userId - , _income_date = date - , _income_amount = amount - , _income_createdAt = createdAt - , _income_editedAt = Nothing - , _income_deletedAt = Nothing - } ) -edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool edit userId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> + income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - do - currentTime <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" - (currentTime, incomeDate, incomeAmount, incomeId, userId) - return . Just $ Income - { _income_id = incomeId - , _income_userId = userId - , _income_date = incomeDate - , _income_amount = incomeAmount - , _income_createdAt = _income_createdAt income - , _income_editedAt = Just currentTime - , _income_deletedAt = Nothing - } - Nothing -> - return Nothing + if Maybe.isJust income then + do + currentTime <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" + (currentTime, incomeDate, incomeAmount, incomeId, userId) + return True + else + return False ) delete :: UserId -> PaymentId -> Query () diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 953f0ae..da877ff 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -190,30 +190,17 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () create userId name cost date category frequency = Query (\conn -> do - time <- getCurrentTime + currentTime <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) - (userId, name, cost, date, category, FrequencyField frequency, time) - paymentId <- SQLite.lastInsertRowId conn - return $ Payment - { _payment_id = paymentId - , _payment_user = userId - , _payment_name = name - , _payment_cost = cost - , _payment_date = date - , _payment_category = category - , _payment_frequency = frequency - , _payment_createdAt = time - , _payment_editedAt = Nothing - , _payment_deletedAt = Nothing - } + (userId, name, cost, date, category, FrequencyField frequency, currentTime) ) createMany :: [Payment] -> Query () @@ -228,17 +215,17 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment) +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Bool edit userId paymentId name cost date category frequency = Query (\conn -> do - mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> SQLite.query conn (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") (paymentId, userId) - case mbPayment of - Just payment -> do - now <- getCurrentTime + if Maybe.isJust payment then + do + currentTime <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " @@ -255,7 +242,7 @@ edit userId paymentId name cost date category frequency = , " id = ?" , " AND user_id = ?" ]) - ( now + ( currentTime , name , cost , date @@ -264,20 +251,9 @@ edit userId paymentId name cost date category frequency = , paymentId , userId ) - return . Just $ Payment - { _payment_id = paymentId - , _payment_user = userId - , _payment_name = name - , _payment_cost = cost - , _payment_date = date - , _payment_category = category - , _payment_frequency = frequency - , _payment_createdAt = _payment_createdAt payment - , _payment_editedAt = Just now - , _payment_deletedAt = Nothing - } - Nothing -> - return Nothing + return True + else + return False ) delete :: UserId -> PaymentId -> Query () diff --git a/server/src/Validation/Category.hs b/server/src/Validation/Category.hs new file mode 100644 index 0000000..12f2117 --- /dev/null +++ b/server/src/Validation/Category.hs @@ -0,0 +1,27 @@ +module Validation.Category + ( createCategory + , editCategory + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Validation.Category as CategoryValidation +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) + +createCategory :: CreateCategoryForm -> Validation Text CreateCategory +createCategory form = + CreateCategory + <$> CategoryValidation.name (_createCategoryForm_name form) + <*> CategoryValidation.color (_createCategoryForm_color form) + +editCategory :: EditCategoryForm -> Validation Text EditCategory +editCategory form = + EditCategory + <$> V.Success (_editCategoryForm_id form) + <*> CategoryValidation.name (_editCategoryForm_name form) + <*> CategoryValidation.color (_editCategoryForm_color form) -- cgit v1.2.3 From 1dfb85d3fd56d163fc854a8b3cf659d0ac39f639 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 17:25:29 +0100 Subject: Search payments by cost too --- server/src/Job/WeeklyReport.hs | 2 +- server/src/Persistence/Payment.hs | 160 ++++++++++++++++++++++---------------- server/src/Persistence/Util.hs | 11 +++ 3 files changed, 106 insertions(+), 67 deletions(-) create mode 100644 server/src/Persistence/Util.hs (limited to 'server/src') diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 16be396..ff80ddf 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -35,7 +35,7 @@ weeklyReport conf mbLastExecution = do _ -> return M.empty - weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index da877ff..a0cd580 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -3,7 +3,7 @@ module Persistence.Payment , find , getRange , listActivePage - , listModifiedSince + , listModifiedPunctualSince , listActiveMonthlyOrderedByName , create , createMany @@ -23,8 +23,8 @@ import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only), - ToRow) +import Database.SQLite.Simple (FromRow (fromRow), + NamedParam ((:=)), ToRow) import qualified Database.SQLite.Simple as SQLite import Database.SQLite.Simple.ToField (ToField (toField)) import Prelude hiding (id, until) @@ -32,11 +32,12 @@ import Prelude hiding (id, until) import Common.Model (CategoryId, Frequency (..), Payment (..), PaymentId, User (..), UserId) +import qualified Common.Util.Text as TextUtil import Model.Query (Query (Query)) import Persistence.Frequency (FrequencyField (..)) import qualified Persistence.Income as IncomePersistence - +import qualified Persistence.Util as PersistenceUtil fields :: Text @@ -90,27 +91,30 @@ count :: Frequency -> Text -> Query Int count frequency search = Query (\conn -> (\[Count n] -> n) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT COUNT(*)" , "FROM payment" , "WHERE" , "deleted_at IS NULL" - , "AND frequency = ?" - , "AND name LIKE ?" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" ]) - (FrequencyField frequency, "%" <> search <> "%") + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + ] ) find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do fmap (\(Row p) -> p) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn - (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?") - (Only paymentId) + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = :id") + [ "id" := paymentId + ] ) data RangeRow = RangeRow (Day, Day) @@ -122,23 +126,24 @@ getRange :: Query (Maybe (Day, Day)) getRange = Query (\conn -> do fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT MIN(date), MAX(date)" , "FROM payment" , "WHERE" - , "frequency = ?" + , "frequency = :frequency" , "AND deleted_at IS NULL" ]) - (Only (FrequencyField Punctual)) + [ ":frequency" := FrequencyField Punctual + ] ) listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] listActivePage frequency page perPage search = Query (\conn -> map (\(Row p) -> p) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT" @@ -146,31 +151,36 @@ listActivePage frequency page perPage search = , "FROM payment" , "WHERE" , "deleted_at IS NULL" - , "AND frequency = ?" - , "AND name LIKE ?" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" , "ORDER BY date DESC" - , "LIMIT ?" - , "OFFSET ?" + , "LIMIT :limit" + , "OFFSET :offset" ] ) - (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] ) -listModifiedSince :: UTCTime -> Query [Payment] -listModifiedSince since = +listModifiedPunctualSince :: UTCTime -> Query [Payment] +listModifiedPunctualSince since = Query (\conn -> map (\(Row i) -> i) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT " <> fields , "FROM payment" , "WHERE" - , "created_at >= ?" - , "OR edited_at >= ?" - , "OR deleted_at >= ?" + , "frequency = :frequency" + , "AND (created_at >= :since OR edited_at >= :since OR deleted_at >= :since)" ]) - (since, since, since) + [ ":frequency" := FrequencyField Punctual + , ":since" := since + ] ) @@ -178,29 +188,37 @@ listActiveMonthlyOrderedByName :: Query [Payment] listActiveMonthlyOrderedByName = Query (\conn -> do map (\(Row p) -> p) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT" , fields , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" + , "WHERE deleted_at IS NULL AND frequency = :frequency" , "ORDER BY name DESC" ]) - (Only (FrequencyField Monthly)) + [ ":frequency" := FrequencyField Monthly + ] ) create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () create userId name cost date category frequency = Query (\conn -> do currentTime <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?, ?)" + , "VALUES (:userId, :name, :cost, :date, :category, :frequency, :currentTime)" ]) - (userId, name, cost, date, category, FrequencyField frequency, currentTime) + [ ":userId" := userId + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":currentTime" := currentTime + ] ) createMany :: [Payment] -> Query () @@ -219,38 +237,41 @@ edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> edit userId paymentId name cost date category frequency = Query (\conn -> do payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn - (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") - (paymentId, userId) + (SQLite.Query $ + "SELECT " <> fields <> " FROM payment WHERE id = :paymentId and user_id = :userId") + [ ":paymentId" := paymentId + , ":userId" := userId + ] if Maybe.isJust payment then do currentTime <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn (SQLite.Query $ T.intercalate " " [ "UPDATE" , " payment" , "SET" - , " edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " category = ?," - , " frequency = ?" + , " edited_at = :editedAt," + , " name = :name," + , " cost = :cost," + , " date = :date," + , " category = :category," + , " frequency = :frequency" , "WHERE" - , " id = ?" - , " AND user_id = ?" + , " id = :id" + , " AND user_id = :userId" ]) - ( currentTime - , name - , cost - , date - , category - , FrequencyField frequency - , paymentId - , userId - ) + [ ":editedAt" := currentTime + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":id" := paymentId + , ":userId" := userId + ] return True else return False @@ -259,10 +280,12 @@ edit userId paymentId name cost date category frequency = delete :: UserId -> PaymentId -> Query () delete userId paymentId = Query (\conn -> - SQLite.execute + SQLite.executeNamed conn - "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" - (paymentId, userId) + "UPDATE payment SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := paymentId + , ":userId" := userId + ] ) data CategoryIdRow = CategoryIdRow CategoryId @@ -274,16 +297,17 @@ searchCategory :: Text -> Query (Maybe CategoryId) searchCategory paymentName = Query (\conn -> fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT category" , "FROM payment" - , "WHERE deleted_at is NULL AND name LIKE ?" + , "WHERE deleted_at is NULL AND name LIKE :name" , "ORDER BY edited_at, created_at" , "LIMIT 1" ]) - (Only $ "%" <> paymentName <> "%") + [ ":name" := "%" <> paymentName <> "%" + ] ) data UserCostRow = UserCostRow (UserId, Int) @@ -297,20 +321,24 @@ instance FromRow UserCostRow where repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) repartition frequency search from to = Query (\conn -> - M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT user_id, SUM(cost)" , "FROM payment" , "WHERE" , "deleted_at IS NULL" - , "AND frequency = ?" - , "AND name LIKE ?" - , "AND date >= ?" - , "AND date < ?" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + , "AND date >= :from" + , "AND date < :to" , "GROUP BY user_id" ]) - (FrequencyField frequency, "%" <> search <> "%", from, to) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":from" := from + , ":to" := to + ] ) getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) diff --git a/server/src/Persistence/Util.hs b/server/src/Persistence/Util.hs new file mode 100644 index 0000000..b7496c6 --- /dev/null +++ b/server/src/Persistence/Util.hs @@ -0,0 +1,11 @@ +module Persistence.Util + ( formatKeyForSearch + ) where + +import Data.Text (Text) + +formatKeyForSearch :: Text -> Text +formatKeyForSearch key = + "replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(" + <> key + <> "), 'à', 'a'), 'â', 'a'), 'ç', 'c'), 'è', 'e'), 'é', 'e'), 'ê', 'e'), 'ë', 'e'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ù', 'u'), 'û', 'u'), 'ü', 'u')" -- cgit v1.2.3 From da2a0c13aa89705c65fdb9df2f496fb4eea29654 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 19:22:45 +0100 Subject: Allow to remove only unused categories --- server/src/Controller/Category.hs | 5 +-- server/src/Persistence/Category.hs | 64 +++++++++++++++++++++++++------------- server/src/Persistence/Payment.hs | 14 +++++++++ 3 files changed, 59 insertions(+), 24 deletions(-) (limited to 'server/src') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 36ce3fc..371ba78 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -22,6 +22,7 @@ import Model.CreateCategory (CreateCategory (..)) import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Payment as PaymentPersistence import qualified Secure import qualified Validation.Category as CategoryValidation @@ -36,8 +37,9 @@ list page perPage = Secure.loggedAction (\_ -> (liftIO . Query.run $ do categories <- CategoryPersistence.list page perPage + usedCategories <- PaymentPersistence.usedCategories count <- CategoryPersistence.count - return $ CategoryPage page categories count + return $ CategoryPage page categories usedCategories count ) >>= json ) @@ -76,7 +78,6 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - -- TODO: delete only if no payment has this category CategoryPersistence.delete categoryId if deleted then diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 2934b28..b0a6fca 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -10,7 +10,7 @@ module Persistence.Category import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) @@ -46,10 +46,12 @@ list :: Int -> Int -> Query [Category] list page perPage = Query (\conn -> map (\(Row c) -> c) <$> - SQLite.query + SQLite.queryNamed conn - "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?" - (perPage, (page - 1) * perPage) + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY name LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] ) listAll :: Query [Category] @@ -60,43 +62,61 @@ listAll = ) create :: Text -> Text -> Query () -create categoryName categoryColor = +create name color = Query (\conn -> do - now <- getCurrentTime - SQLite.execute + currentTime <- getCurrentTime + SQLite.executeNamed conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) + "INSERT INTO category (name, color, created_at) VALUES (:name, :color, :created_at)" + [ ":name" := name + , ":color" := color + , ":created_at" := currentTime + ] ) edit :: CategoryId -> Text -> Text -> Query Bool -edit categoryId categoryName categoryColor = +edit id name color = Query (\conn -> do mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + (SQLite.queryNamed conn "SELECT * FROM category WHERE id = :id" [ ":id" := id ]) if Maybe.isJust mbCategory then do - now <- getCurrentTime - SQLite.execute + currentTime <- getCurrentTime + SQLite.executeNamed conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) + "UPDATE category SET edited_at = :editedAt, name = :name, color = :color WHERE id = :id" + [ ":editedAt" := currentTime + , ":name" := name + , ":color" := color + , ":id" := id + ] return True else return False ) +data BoolRow = BoolRow Int + +instance FromRow BoolRow where + fromRow = BoolRow <$> SQLite.field + delete :: CategoryId -> Query Bool -delete categoryId = +delete id = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if Maybe.isJust mbCategory + mbPayment <- (fmap (\(BoolRow b) -> b) . Maybe.listToMaybe) <$> + (SQLite.queryNamed + conn + "SELECT true FROM payment WHERE category = :id AND deleted_at IS NULL" + [ ":id" := id ]) + if Maybe.isNothing mbPayment then do - now <- getCurrentTime - SQLite.execute + currentTime <- getCurrentTime + SQLite.executeNamed conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + "UPDATE category SET deleted_at = :deletedAt WHERE id = :id AND deleted_at IS NULL" + [ ":deletedAt" := currentTime + , ":id" := id + ] return True else return False diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index a0cd580..b3eb141 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -12,6 +12,7 @@ module Persistence.Payment , searchCategory , repartition , getPreAndPostPaymentRepartition + , usedCategories ) where import Data.Map (Map) @@ -310,6 +311,19 @@ searchCategory paymentName = ] ) +usedCategories :: Query [CategoryId] +usedCategories = + Query (\conn -> do + map (\(CategoryIdRow p) -> p) <$> + SQLite.query_ + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT DISTINCT category" + , "FROM payment" + , "WHERE deleted_at IS NULL" + ]) + ) + data UserCostRow = UserCostRow (UserId, Int) instance FromRow UserCostRow where -- cgit v1.2.3 From fff99e6fb1c03235e219a94ce52acf5a50d3fb62 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 5 Jan 2020 16:03:48 +0100 Subject: Use named parameters instead of positional parameters in persistence queries --- server/src/Persistence/Income.hs | 56 ++++++++++++++++++++++++---------------- server/src/Persistence/User.hs | 9 ++++--- 2 files changed, 40 insertions(+), 25 deletions(-) (limited to 'server/src') diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cd98814..76cb952 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -17,8 +17,7 @@ import qualified Data.Text as T import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)), - Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id, until) @@ -55,63 +54,76 @@ list :: Int -> Int -> Query [Income] list page perPage = Query (\conn -> map (\(Row i) -> i) <$> - SQLite.query + SQLite.queryNamed conn - "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" - (perPage, (page - 1) * perPage) + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] ) listModifiedSince :: UTCTime -> Query [Income] listModifiedSince since = Query (\conn -> map (\(Row i) -> i) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT *" , "FROM income" , "WHERE" - , "created_at >= ?" - , "OR edited_at >= ?" - , "OR deleted_at >= ?" + , "created_at >= :since" + , "OR edited_at >= :since" + , "OR deleted_at >= :since" ]) - (since, since, since) + [ ":since" := since ] ) create :: UserId -> Day -> Int -> Query () create userId date amount = Query (\conn -> do createdAt <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (userId, date, amount, createdAt) + "INSERT INTO income (user_id, date, amount, created_at) VALUES (:userId, :date, :amount, :createdAt)" + [ ":userId" := userId + , ":date" := date + , ":amount" := amount + , ":createdAt" := createdAt + ] ) edit :: UserId -> IncomeId -> Day -> Int -> Query Bool -edit userId incomeId incomeDate incomeAmount = +edit userId id date amount = Query (\conn -> do income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> - SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + SQLite.queryNamed conn "SELECT * FROM income WHERE id = :id" [ ":id" := id ] if Maybe.isJust income then do currentTime <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" - (currentTime, incomeDate, incomeAmount, incomeId, userId) + "UPDATE income SET edited_at = :editedAt, date = :date, amount = :amount WHERE id = :id AND user_id = :userId" + [ ":editedAt" := currentTime + , ":date" := date + , ":amount" := amount + , ":id" := id + , ":userId" := userId + ] return True else return False ) delete :: UserId -> PaymentId -> Query () -delete userId paymentId = +delete userId id = Query (\conn -> - SQLite.execute + SQLite.executeNamed conn - "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" - (paymentId, userId) + "UPDATE income SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := id + , ":userId" := userId + ] ) data UserDayRow = UserDayRow (UserId, Day) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 3c3a2b1..89eb57d 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -5,7 +5,7 @@ module Persistence.User import qualified Data.Maybe as Maybe import Data.Text (Text) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) @@ -30,8 +30,11 @@ list = ) get :: Text -> Query (Maybe User) -get userEmail = +get email = Query (\conn -> do fmap (\(Row u) -> u) . Maybe.listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + SQLite.queryNamed + conn + "SELECT * FROM user WHERE email = :email LIMIT 1" + [ ":email" := email ] ) -- cgit v1.2.3 From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- server/src/Controller/Index.hs | 128 ++++++++++++------------------------- server/src/Main.hs | 8 +-- server/src/Model/HashedPassword.hs | 27 ++++++++ server/src/Model/SignIn.hs | 60 +---------------- server/src/Persistence/User.hs | 48 ++++++++++++-- server/src/Secure.hs | 27 ++------ server/src/Validation/SignIn.hs | 16 +++++ server/src/View/Mail/SignIn.hs | 21 ------ server/src/View/Page.hs | 9 +-- 9 files changed, 145 insertions(+), 199 deletions(-) create mode 100644 server/src/Model/HashedPassword.hs create mode 100644 server/src/Validation/SignIn.hs delete mode 100644 server/src/View/Mail/SignIn.hs (limited to 'server/src') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 3788685..4f4ae77 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,120 +1,76 @@ module Controller.Index ( get - , askSignIn - , trySignIn + , signIn , signOut ) where import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as Json import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status -import Prelude hiding (error) +import Prelude hiding (error, init) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), Init (..), - InitResult (..), SignInForm (..), +import Common.Model (Init (..), SignInForm (..), User (..)) -import Common.Msg (Key) import qualified Common.Msg as Msg -import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession +import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn +import Model.SignIn (SignIn (..)) import qualified Persistence.User as UserPersistence -import qualified Secure -import qualified SendMail -import qualified View.Mail.SignIn as SignIn +import qualified Validation.SignIn as SignInValidation import View.Page (page) get :: Conf -> ActionM () get conf = do - initResult <- do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of + init <- do + mbToken <- LoginSession.get + case mbToken of Nothing -> - return InitEmpty - Just user -> do - users <- liftIO . Query.run $ UserPersistence.list - return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) - S.html $ page initResult + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init -askSignIn :: Conf -> SignInForm -> ActionM () -askSignIn conf form = +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = case SignInValidation.signIn form of - Nothing -> - textKey Status.badRequest400 Msg.SignIn_EmailInvalid - Just (Email email) -> do - maybeUser <- liftIO . Query.run $ UserPersistence.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, - "/api/signIn/", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized - where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init -trySignIn :: Conf -> Text -> ActionM () -trySignIn conf token = do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - S.html $ page (InitError $ Msg.get errorKey) - Right _ -> - S.redirect "/" - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of Nothing -> - return . Left $ Msg.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Msg.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Msg.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - UserPersistence.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Msg.Secure_Unauthorized - Just user -> Right user + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) Nothing -> return Nothing - Just token -> do - liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Main.hs b/server/src/Main.hs index 0b80de0..324557e 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -28,12 +28,8 @@ main = do S.middleware . staticPolicy $ noDots >-> addBase "public" - S.post "/api/askSignIn" $ - S.jsonData >>= Index.askSignIn conf - - S.get "/api/signIn/:signInToken" $ do - signInToken <- S.param "signInToken" - Index.trySignIn conf signInToken + S.post "/api/signIn" $ + S.jsonData >>= Index.signIn conf S.post "/api/signOut" $ Index.signOut conf diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs new file mode 100644 index 0000000..c71e372 --- /dev/null +++ b/server/src/Model/HashedPassword.hs @@ -0,0 +1,27 @@ +module Model.HashedPassword + ( hash + , check + , HashedPassword(..) + ) where + +import qualified Crypto.BCrypt as BCrypt +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Common.Model.Password (Password (..)) + +newtype HashedPassword = HashedPassword Text deriving (Show) + +hash :: Password -> IO (Maybe HashedPassword) +hash (Password p) = do + hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p) + case hashed of + Nothing -> + return Nothing + + Just h -> + return . Just . HashedPassword . TE.decodeUtf8 $ h + +check :: Password -> HashedPassword -> Bool +check (Password p) (HashedPassword h) = + BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p) diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index bcdce61..a217bae 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -1,64 +1,10 @@ module Model.SignIn ( SignIn(..) - , createSignInToken - , getSignIn - , signInTokenToUsed - , isLastTokenValid ) where -import Data.Int (Int64) -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Model.Query (Query (Query)) -import Model.UUID (generateUUID) - -type SignInId = Int64 +import Common.Model (Email, Password) data SignIn = SignIn - { id :: SignInId - , token :: Text - , creation :: UTCTime - , email :: Text - , isUsed :: Bool + { _signIn_email :: Email + , _signIn_password :: Password } deriving Show - -instance FromRow SignIn where - fromRow = SignIn <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -createSignInToken :: Text -> Query Text -createSignInToken signInEmail = - Query (\conn -> do - now <- getCurrentTime - signInToken <- generateUUID - SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) - return signInToken - ) - -getSignIn :: Text -> Query (Maybe SignIn) -getSignIn signInToken = - Query (\conn -> do - Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) - ) - -signInTokenToUsed :: SignInId -> Query () -signInTokenToUsed tokenId = - Query (\conn -> - SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) - ) - -isLastTokenValid :: SignIn -> Query Bool -isLastTokenValid signIn = - Query (\conn -> do - [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) - return . maybe False (== (token signIn)) $ lastToken - ) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 89eb57d..12145ac 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -1,17 +1,21 @@ module Persistence.User ( list , get + , checkPassword + , createSignInToken ) where import qualified Data.Maybe as Maybe import Data.Text (Text) import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) -import Common.Model (User (..)) +import Common.Model (Email (..), Password (..), User (..)) +import Model.HashedPassword (HashedPassword (..)) +import qualified Model.HashedPassword as HashedPassword import Model.Query (Query (Query)) +import qualified Model.UUID as UUID newtype Row = Row User @@ -26,15 +30,49 @@ list :: Query [User] list = Query (\conn -> do map (\(Row u) -> u) <$> - SQLite.query_ conn "SELECT * from user ORDER BY creation DESC" + SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC" ) get :: Text -> Query (Maybe User) -get email = +get token = Query (\conn -> do fmap (\(Row u) -> u) . Maybe.listToMaybe <$> SQLite.queryNamed conn - "SELECT * FROM user WHERE email = :email LIMIT 1" + "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1" + [ ":sign_in_token" := token ] + ) + +data HashedPasswordRow = HashedPasswordRow HashedPassword + +instance FromRow HashedPasswordRow where + fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field) + +checkPassword :: Email -> Password -> Query Bool +checkPassword (Email email) password = + Query (\conn -> do + hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT password FROM user WHERE email = :email LIMIT 1" [ ":email" := email ] + case hashedPassword of + Just h -> + return (HashedPassword.check password h) + + Nothing -> + return False + ) + +createSignInToken :: Email -> Query Text +createSignInToken (Email email) = + Query (\conn -> do + token <- UUID.generateUUID + SQLite.executeNamed + conn + "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email" + [ ":sign_in_token" := token + , ":email" := email + ] + return token ) diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 4fb2333..a30941f 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -1,21 +1,17 @@ module Secure ( loggedAction - , getUserFromToken ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) +import qualified Data.Text.Lazy as TL +import qualified Network.HTTP.Types.Status as HTTP import Web.Scotty import Common.Model (User) import qualified Common.Msg as Msg import qualified LoginSession -import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn import qualified Persistence.User as UserPersistence loggedAction :: (User -> ActionM ()) -> ActionM () @@ -23,22 +19,13 @@ loggedAction action = do maybeToken <- LoginSession.get case maybeToken of Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token + maybeUser <- liftIO . Query.run . UserPersistence.get $ token case maybeUser of Just user -> action user Nothing -> do - status forbidden403 - html . fromStrict . Msg.get $ Msg.Secure_Unauthorized + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized Nothing -> do - status forbidden403 - html . fromStrict . Msg.get $ Msg.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - UserPersistence.get (SignIn.email signIn) - Nothing -> - return Nothing + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs new file mode 100644 index 0000000..dc86122 --- /dev/null +++ b/server/src/Validation/SignIn.hs @@ -0,0 +1,16 @@ +module Validation.SignIn + ( signIn + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model (SignInForm (..)) +import qualified Common.Validation.SignIn as SignInValidation +import Model.SignIn (SignIn (..)) + +signIn :: SignInForm -> Validation Text SignIn +signIn form = + SignIn + <$> SignInValidation.email (_signInForm_email form) + <*> SignInValidation.password (_signInForm_password form) diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs deleted file mode 100644 index 3c5469f..0000000 --- a/server/src/View/Mail/SignIn.hs +++ /dev/null @@ -1,21 +0,0 @@ -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import Common.Model (User (..)) -import qualified Common.Msg as Msg - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Msg.get Msg.SignIn_MailTitle - , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url) - } diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index f47c544..4ada5f7 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -6,6 +6,7 @@ import Data.Aeson (encode) import qualified Data.Aeson.Types as Json import Data.Text.Internal.Lazy (Text) import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (init) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -14,20 +15,20 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A -import Common.Model (InitResult) +import Common.Model (Init) import qualified Common.Msg as Msg import Design.Global (globalDesign) -page :: InitResult -> Text -page initResult = +page :: Maybe Init -> Text +page init = renderHtml . docTypeHtml $ do H.head $ do 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" $ "" - jsonScript "init" initResult + jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign -- cgit v1.2.3 From 209008f155068835077719eeec942a9b979b3a04 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 16:14:09 +0100 Subject: Keep button size while waiting --- server/src/Design/Global.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src') diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index ebd7084..c67db7c 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -132,7 +132,7 @@ global = do ".waiting" & do ".content" ? do - display none + opacity 0 svg # ".loader" ? do display block spinAnimation -- cgit v1.2.3 From 5a13317efdaa2a8594a138b07ddd45eab40a8322 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 16:30:01 +0100 Subject: Return the css at /css/main.css instead of inlined --- server/src/Main.hs | 5 +++++ server/src/View/Page.hs | 4 +--- 2 files changed, 6 insertions(+), 3 deletions(-) (limited to 'server/src') diff --git a/server/src/Main.hs b/server/src/Main.hs index 324557e..999f973 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -14,6 +14,7 @@ import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment import qualified Controller.User as User +import qualified Design.Global as Design import Job.Daemon (runDaemons) main :: IO () @@ -28,6 +29,10 @@ main = do S.middleware . staticPolicy $ noDots >-> addBase "public" + S.get "/css/main.css" $ do + S.setHeader "Content-Type" "text/css" + S.text Design.globalDesign + S.post "/api/signIn" $ S.jsonData >>= Index.signIn conf diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 4ada5f7..bac6b8a 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -18,8 +18,6 @@ import qualified Text.Blaze.Html5.Attributes as A import Common.Model (Init) import qualified Common.Msg as Msg -import Design.Global (globalDesign) - page :: Maybe Init -> Text page init = renderHtml . docTypeHtml $ do @@ -30,8 +28,8 @@ page init = script ! src "/javascript/main.js" $ "" jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" - H.style $ toHtml globalDesign H.body $ do H.div ! A.class_ "spinner" $ "" -- cgit v1.2.3 From d20d7ceec2a14f79ebb06555a71d424aeaa90e54 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 16:31:55 +0100 Subject: Show conf at server startup --- server/src/Main.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'server/src') diff --git a/server/src/Main.hs b/server/src/Main.hs index 999f973..25fffb3 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -20,6 +20,7 @@ import Job.Daemon (runDaemons) main :: IO () main = do conf <- Conf.get "application.conf" + putStrLn . show $ conf _ <- runDaemons conf S.scotty (Conf.port conf) $ do -- cgit v1.2.3 From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 20 Jan 2020 19:47:23 +0100 Subject: Show payment stats --- server/src/Controller/Payment.hs | 9 +++++++++ server/src/Design/View/Stat.hs | 4 ++++ server/src/Design/Views.hs | 2 +- server/src/Main.hs | 3 +++ server/src/Persistence/Payment.hs | 19 +++++++++++++++++++ server/src/Statistics.hs | 34 ++++++++++++++++++++++++++++++++++ server/src/View/Page.hs | 1 + 7 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 server/src/Statistics.hs (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index d6aa34f..80c717f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -4,6 +4,7 @@ module Controller.Payment , edit , delete , searchCategory + , statistics ) where import Control.Monad.IO.Class (liftIO) @@ -30,6 +31,7 @@ import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence import qualified Secure +import qualified Statistics import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () @@ -114,3 +116,10 @@ searchCategory paymentName = (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) >>= S.json ) + +statistics :: ActionM () +statistics = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + S.json (Statistics.compute payments) + ) diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index 4d7021e..2e4ecad 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -11,3 +11,7 @@ design = do ".exceedingPayers" ? ".userName" ? marginRight (px 5) ".mean" ? marginBottom (em 1.5) + + ".g-Chart" ? do + width (pct 75) + sym2 margin (px 0) auto diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 270bb8e..4552796 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -22,7 +22,7 @@ design = do header ? Header.design Payment.design ".signIn" ? SignIn.design - ".stat" ? Stat.design + Stat.design ".notfound" ? NotFound.design Table.design Pages.design diff --git a/server/src/Main.hs b/server/src/Main.hs index 25fffb3..64de511 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -97,6 +97,9 @@ main = do categoryId <- S.param "id" Category.delete categoryId + S.get "/api/statistics" $ do + Payment.statistics + S.notFound $ do S.status Status.ok200 Index.get conf diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index b3eb141..573d57f 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -2,6 +2,7 @@ module Persistence.Payment ( count , find , getRange + , listAllPunctual , listActivePage , listModifiedPunctualSince , listActiveMonthlyOrderedByName @@ -140,6 +141,24 @@ getRange = ] ) +listAllPunctual :: Query [Payment] +listAllPunctual = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = :frequency" + , "ORDER BY date" + ]) + [ ":frequency" := FrequencyField Punctual + ] + ) + + listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] listActivePage frequency page perPage search = Query (\conn -> diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs new file mode 100644 index 0000000..371fba2 --- /dev/null +++ b/server/src/Statistics.hs @@ -0,0 +1,34 @@ +module Statistics + ( compute + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Time.Calendar as Calendar + +import Common.Model (Payment (..), PaymentStats) + +compute :: [Payment] -> PaymentStats +compute payments = + + M.toList $ foldl + (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m) + M.empty + payments + + where + + initMonthStats = + M.fromList + . map (\category -> (category, 0)) + . L.nub + $ map _payment_category payments + + alter p Nothing = Just (addPayment p initMonthStats) + alter p (Just monthStats) = Just (addPayment p monthStats) + + addPayment p monthStats = M.adjust ((+) (_payment_cost p)) (_payment_category p) monthStats + + startOfMonth day = + let (y, m, _) = Calendar.toGregorian day + in Calendar.fromGregorian y m 1 diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index bac6b8a..ae7a266 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -26,6 +26,7 @@ page init = 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 "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ "" jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" -- cgit v1.2.3 From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 27 Jan 2020 22:07:18 +0100 Subject: Show total incom by month in statistics --- server/src/Controller/Payment.hs | 9 --------- server/src/Controller/Statistics.hs | 21 +++++++++++++++++++++ server/src/Main.hs | 3 ++- server/src/Persistence/Income.hs | 13 ++++++++++++- server/src/Statistics.hs | 35 ++++++++++++++++++++++++++++++----- 5 files changed, 65 insertions(+), 16 deletions(-) create mode 100644 server/src/Controller/Statistics.hs (limited to 'server/src') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 80c717f..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -4,7 +4,6 @@ module Controller.Payment , edit , delete , searchCategory - , statistics ) where import Control.Monad.IO.Class (liftIO) @@ -31,7 +30,6 @@ import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Statistics import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () @@ -116,10 +114,3 @@ searchCategory paymentName = (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) >>= S.json ) - -statistics :: ActionM () -statistics = - Secure.loggedAction (\_ -> do - payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual - S.json (Statistics.compute payments) - ) diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs new file mode 100644 index 0000000..500c93c --- /dev/null +++ b/server/src/Controller/Statistics.hs @@ -0,0 +1,21 @@ +module Controller.Statistics + ( paymentsAndIncomes + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Statistics + +paymentsAndIncomes :: ActionM () +paymentsAndIncomes = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + incomes <- liftIO $ Query.run IncomePersistence.listAll + S.json (Statistics.paymentsAndIncomes payments incomes) + ) diff --git a/server/src/Main.hs b/server/src/Main.hs index 64de511..659a0fa 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -13,6 +13,7 @@ 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.Statistics as Statistics import qualified Controller.User as User import qualified Design.Global as Design import Job.Daemon (runDaemons) @@ -98,7 +99,7 @@ main = do Category.delete categoryId S.get "/api/statistics" $ do - Payment.statistics + Statistics.paymentsAndIncomes S.notFound $ do S.status Status.ok200 diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 76cb952..1b5364c 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,5 +1,6 @@ module Persistence.Income - ( count + ( listAll + , count , list , listModifiedSince , create @@ -43,6 +44,16 @@ data CountRow = CountRow Int instance FromRow CountRow where fromRow = CountRow <$> SQLite.field +listAll :: Query [Income] +listAll = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC" + ) + + count :: Query Int count = Query (\conn -> diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs index 371fba2..e463aac 100644 --- a/server/src/Statistics.hs +++ b/server/src/Statistics.hs @@ -1,23 +1,44 @@ module Statistics - ( compute + ( paymentsAndIncomes ) where +import Control.Arrow ((&&&)) import qualified Data.List as L +import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Maybe as Maybe import qualified Data.Time.Calendar as Calendar -import Common.Model (Payment (..), PaymentStats) +import Common.Model (Income (..), MonthStats (..), Payment (..), + Stats) -compute :: [Payment] -> PaymentStats -compute payments = +paymentsAndIncomes :: [Payment] -> [Income] -> Stats +paymentsAndIncomes payments incomes = - M.toList $ foldl + map toMonthStat . M.toList $ foldl (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m) M.empty payments where + toMonthStat (start, paymentsByCategory) = + MonthStats start paymentsByCategory (incomesAt start) + + incomesAt day = + M.map (incomeAt day) lastToFirstIncomesByUser + + incomeAt day lastToFirstIncome = + Maybe.maybe 0 _income_amount + . Maybe.listToMaybe + . dropWhile (\i -> _income_date i > day) + $ lastToFirstIncome + + lastToFirstIncomesByUser = + M.map (reverse . L.sortOn _income_date) + . groupBy _income_userId + $ incomes + initMonthStats = M.fromList . map (\category -> (category, 0)) @@ -32,3 +53,7 @@ compute payments = startOfMonth day = let (y, m, _) = Calendar.toGregorian day in Calendar.fromGregorian y m 1 + +groupBy :: Ord k => (a -> k) -> [a] -> Map k [a] +groupBy key = + M.fromListWith (++) . map (key &&& pure) -- cgit v1.2.3