diff options
Diffstat (limited to 'src/server')
60 files changed, 568 insertions, 1885 deletions
diff --git a/src/server/Common b/src/server/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/server/Common @@ -0,0 +1 @@ +../common
\ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs index a05349d..92df4e9 100644 --- a/src/server/Conf.hs +++ b/src/server/Conf.hs @@ -10,11 +10,13 @@ import qualified Data.Text as T import qualified Data.ConfigManager as Conf import Data.Time.Clock (NominalDiffTime) +import Common.Model.Currency (Currency(..)) + data Conf = Conf { hostname :: Text , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Text + , currency :: Currency , noReplyMail :: Text , https :: Bool } deriving Show @@ -28,7 +30,7 @@ get path = do Conf.lookup "hostname" conf <*> Conf.lookup "port" conf <*> Conf.lookup "signInExpiration" conf <*> - Conf.lookup "currency" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> Conf.lookup "https" conf ) diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 3f800da..1a44083 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -11,12 +11,14 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty hiding (delete) +import Common.Model.Category (CategoryId) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.CreateCategory as Json +import qualified Common.Model.EditCategory as Json + import Json (jsonId) -import Model.Category (CategoryId) import qualified Model.Category as Category -import qualified Model.Json.CreateCategory as Json -import qualified Model.Json.EditCategory as Json -import qualified Model.Message.Key as Key import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query import qualified Secure @@ -49,5 +51,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.CategoryNotDeleted + text . TL.fromStrict $ Message.get Key.Category_NotDeleted ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 18394d0..148b713 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -11,26 +11,25 @@ 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 Model.Income (IncomeId) import qualified Model.Income as Income -import qualified Model.Json.CreateIncome as Json -import qualified Model.Json.EditIncome as Json -import qualified Model.Message.Key as Key import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure -create :: Json.CreateIncome -> ActionM () -create (Json.CreateIncome date amount) = +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId ) -editOwn :: Json.EditIncome -> ActionM () -editOwn (Json.EditIncome incomeId date amount) = +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 $ Income.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -45,5 +44,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.IncomeNotDeleted + text . TL.fromStrict $ Message.get Key.Income_NotDeleted ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 9fb2aa0..8473c5c 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -7,15 +7,17 @@ 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 Model.Json.Init (InitResult(..)) -import Model.Message.Key -import Model.User (User) import qualified LoginSession -import qualified Model.Json.Conf as M import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -29,17 +31,17 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitError $ errorKey + return . InitEmpty . Left . Message.get $ errorKey Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return InitEmpty + return . InitEmpty . Right $ Nothing Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) initResult + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -52,23 +54,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ SignInInvalid + return . Left $ Key.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ SignInUsed + return . Left $ Key.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ SignInExpired + return . Left $ Key.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn + User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left UnauthorizedSignIn + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d71b451..6a9ede7 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -11,37 +11,36 @@ import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status (ok200, badRequest400) import Web.Scotty +import qualified Common.Model.CreatePayment as M +import qualified Common.Model.EditPayment as M +import Common.Model (PaymentId, User(..)) + import Json (jsonId) -import Model.Payment (PaymentId) -import qualified Model.Json.CreatePayment as Json -import qualified Model.Json.EditPayment as Json -import qualified Model.Json.Payment as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json + (liftIO . Query.run $ Payment.list) >>= json ) -create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date category frequency) = +create :: M.CreatePayment -> ActionM () +create (M.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 + Payment.create (_user_id user) name cost date frequency ) >>= jsonId ) -editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date category frequency) = +editOwn :: M.EditPayment -> ActionM () +editOwn (M.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 <- Payment.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -54,7 +53,7 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId if deleted then status ok200 else status badRequest400 diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 152168c..932ce53 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -5,15 +5,17 @@ module Controller.SignIn ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) 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 qualified Common.Model.SignIn as M + import Conf (Conf) -import Model.Message.Key import qualified Conf import qualified Model.Query as Query import qualified Model.SignIn as SignIn @@ -22,30 +24,24 @@ import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn -signIn :: Conf -> Text -> ActionM () -signIn conf login = - if Email.isValid (TE.encodeUtf8 login) +signIn :: Conf -> M.SignIn -> ActionM () +signIn conf (M.SignIn email) = + if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.getUser login + maybeUser <- liftIO . Query.run $ User.get email case maybeUser of Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login + 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 [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> - status ok200 - Left _ -> do - status badRequest400 - text . TL.pack . show $ SendEmailFail - Nothing -> do - status badRequest400 - text . TL.pack . show $ UnauthorizedSignIn - else do - status badRequest400 - text . TL.pack . show $ EnterValidEmail + 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/src/server/Controller/User.hs b/src/server/Controller/User.hs deleted file mode 100644 index d8604ac..0000000 --- a/src/server/Controller/User.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.User - ( getUsers - ) where - -import Web.Scotty - -import Control.Monad.IO.Class (liftIO) - -import qualified Secure - -import Model.Database -import qualified Model.User as User - -getUsers :: ActionM () -getUsers = - Secure.loggedAction (\_ -> - (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json - ) diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index afc601f..06c468e 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -7,6 +7,9 @@ import qualified Clay.Color as C white :: C.Color white = C.white +black :: C.Color +black = C.black + chestnutRose :: C.Color chestnutRose = C.rgb 207 92 86 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index e742978..47ea4a9 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -8,9 +8,7 @@ import Clay import Data.Text.Lazy (Text) -import qualified Design.Header as Header -import qualified Design.SignIn as SignIn -import qualified Design.LoggedIn as LoggedIn +import qualified Design.Views as Views import qualified Design.Form as Form import qualified Design.Errors as Errors import qualified Design.Dialog as Dialog @@ -26,13 +24,10 @@ globalDesign = renderWith compact [] global global :: Css global = do - - header ? Header.design - ".signIn" ? SignIn.design - ".loggedIn" ? LoggedIn.design ".errors" ? Errors.design ".dialog" ? Dialog.design ".tooltip" ? Tooltip.design + Views.design Form.design body ? do @@ -49,6 +44,8 @@ global = do a ? cursor pointer + input ? fontSize inherit + h1 ? do color Color.chestnutRose marginBottom (em 1) diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index 869616d..41528ed 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -3,8 +3,8 @@ module Design.Helper ( clearFix , button + , waitable , input - , iconButton , centeredWithMargin , verticalCentering ) where @@ -13,8 +13,6 @@ import Prelude hiding (span) import Clay hiding (button, input) -import Data.Monoid ((<>)) - import Design.Constants import Design.Color as Color @@ -27,6 +25,9 @@ clearFix = button :: Color -> 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 @@ -38,19 +39,20 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) + waitable -iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css -iconButton backgroundCol textCol h focusOp = do - button backgroundCol textCol h focusOp - i <> span ? do - height h - lineHeight h - span ? do - display inlineBlock - marginLeft (px 20) - i ? do - marginLeft (px 15) - marginRight (px 20) +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 @@ -72,3 +74,17 @@ 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/src/server/Design/LoggedIn/Home.hs b/src/server/Design/LoggedIn/Home.hs deleted file mode 100644 index 7845434..0000000 --- a/src/server/Design/LoggedIn/Home.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home.Header as Header -import qualified Design.LoggedIn.Home.Table as Table -import qualified Design.LoggedIn.Home.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs deleted file mode 100644 index 75f2f98..0000000 --- a/src/server/Design/SignIn.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.SignIn - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - - form ? 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.iconButton Color.gothic Color.white (px inputHeight) Constants.focusLighten - display block - width (pct 100) - fontSize (em 1.2) - ".waitingServer" & ("cursor" -: "not-allowed") - - ".result" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/Header.hs b/src/server/Design/View/Header.hs index 8feac64..20627e6 100644 --- a/src/server/Design/Header.hs +++ b/src/server/Design/View/Header.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.Header +module Design.View.Header ( design ) where @@ -9,6 +9,7 @@ import Data.Monoid ((<>)) import Clay import Design.Color as Color +import qualified Design.Helper as Helper import qualified Design.Media as Media design :: Css @@ -57,9 +58,12 @@ design = do 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 diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/src/server/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/src/server/Design/LoggedIn/Home/Header.hs b/src/server/Design/View/Payment/Header.hs index 5fd2d79..f02da8a 100644 --- a/src/server/Design/LoggedIn/Home/Header.hs +++ b/src/server/Design/View/Payment/Header.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Home.Header +module Design.View.Payment.Header ( design ) where diff --git a/src/server/Design/LoggedIn/Home/Pages.hs b/src/server/Design/View/Payment/Pages.hs index 71f3254..ade81a8 100644 --- a/src/server/Design/LoggedIn/Home/Pages.hs +++ b/src/server/Design/View/Payment/Pages.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Home.Pages +module Design.View.Payment.Pages ( design ) where diff --git a/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/View/Payment/Table.hs index cb46ac9..a866b40 100644 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ b/src/server/Design/View/Payment/Table.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Home.Table +module Design.View.Payment.Table ( design ) where import Clay +import qualified Design.Color as Color import qualified Design.Media as Media design :: Css @@ -35,3 +36,7 @@ design = 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/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/src/server/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/src/server/Design/LoggedIn/Stat.hs b/src/server/Design/View/Stat.hs index 62028cb..0a5b258 100644 --- a/src/server/Design/LoggedIn/Stat.hs +++ b/src/server/Design/View/Stat.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Stat +module Design.View.Stat ( design ) where diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/View/Table.hs index 44b001a..95abf90 100644 --- a/src/server/Design/LoggedIn/Table.hs +++ b/src/server/Design/View/Table.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Table +module Design.View.Table ( design ) where diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/Views.hs index 4a21832..bc6ac83 100644 --- a/src/server/Design/LoggedIn.hs +++ b/src/server/Design/Views.hs @@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn +module Design.Views ( design ) where import Clay -import qualified Design.LoggedIn.Home as Home -import qualified Design.LoggedIn.Stat as Stat -import qualified Design.LoggedIn.Table as Table +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 @@ -17,7 +19,9 @@ import qualified Design.Media as Media design :: Css design = do - ".home" ? Home.design + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design ".stat" ? Stat.design Table.design diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index 8c11ccf..ba24cca 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -4,7 +4,8 @@ module Job.MonthlyPayment import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Frequency +import Common.Model (Frequency(..), Payment(..)) + import qualified Model.Payment as Payment import Utils.Time (timeToDay) import qualified Model.Query as Query @@ -14,6 +15,12 @@ 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 + 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/src/server/Main.hs b/src/server/Main.hs index 17c2594..db73474 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -1,16 +1,25 @@ {-# 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 Job.Daemon (runDaemons) 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 @@ -19,13 +28,19 @@ main = do 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 - email <- param "email" - SignIn.signIn conf email + jsonData >>= SignIn.signIn conf post "/signOut" $ Index.signOut conf diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs index 9597bd9..6b7a488 100644 --- a/src/server/Model/Category.hs +++ b/src/server/Model/Category.hs @@ -1,34 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category - ( CategoryId - , Category(..) - , list + ( list , create , edit , delete ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) 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 Model.Query (Query(Query)) - -type CategoryId = Int64 +import Common.Model (Category(..), CategoryId) -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow Category where fromRow = Category <$> diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs index f9958e1..4f7b83d 100644 --- a/src/server/Model/Frequency.hs +++ b/src/server/Model/Frequency.hs @@ -1,28 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Model.Frequency - ( Frequency(..) - ) where +module Model.Frequency () where -import Data.Aeson 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 GHC.Generics import qualified Data.Text as T -import Web.Scotty (parseParam, Parsable, readEither) -data Frequency = - Punctual - | Monthly - deriving (Eq, Show, Read, Generic) - -instance Parsable Frequency where parseParam = readEither -instance FromJSON Frequency -instance ToJSON Frequency +import Common.Model.Frequency (Frequency) instance FromField Frequency where fromField field = case fieldData field of diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index c6cdb55..bbe7657 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income - ( IncomeId - , Income(..) - , list + ( list , create , editOwn , deleteOwn , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime, getCurrentTime) @@ -18,27 +16,15 @@ 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 Model.User (User, UserId) -import qualified Model.User as User import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type IncomeId = Int64 - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Income where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt instance FromRow Income where fromRow = Income <$> @@ -70,7 +56,7 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == incomeUserId + if _income_userId income == incomeUserId then do now <- getCurrentTime SQLite.execute @@ -90,7 +76,7 @@ deleteOwn user incomeId = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == User.id user + if _income_userId income == _user_id user then do now <- getCurrentTime SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 7a9ccea..8c6a961 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -4,27 +4,24 @@ module Model.Init ( getInit ) where -import Model.Json.Init (Init) +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf import Model.Query (Query) -import Model.User (User) import qualified Model.Category as Category import qualified Model.Income as Income -import qualified Model.Json.Category as Json -import qualified Model.Json.Income as Json -import qualified Model.Json.Init as Init -import qualified Model.Json.Payment as Json -import qualified Model.Json.PaymentCategory as Json -import qualified Model.Json.User as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.User as User -getInit :: User -> Query Init -getInit user = - Init.Init <$> - (map Json.fromUser <$> User.list) <*> - (return . User.id $ user) <*> - (map Json.fromPayment <$> Payment.list) <*> - (map Json.fromIncome <$> Income.list) <*> - (map Json.fromCategory <$> Category.list) <*> - (map Json.fromPaymentCategory <$> PaymentCategory.list) +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/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs deleted file mode 100644 index 8b5e527..0000000 --- a/src/server/Model/Json/Category.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Category - ( Category(..) - , fromCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.Category as M - -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance ToJSON Category - -fromCategory :: M.Category -> Category -fromCategory category = Category (M.id category) (M.name category) (M.color category) diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs deleted file mode 100644 index a66fb55..0000000 --- a/src/server/Model/Json/Conf.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Conf - ( Conf(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -data Conf = Conf - { currency :: Text - } deriving (Show, Generic) - -instance FromJSON Conf -instance ToJSON Conf diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs deleted file mode 100644 index fffc882..0000000 --- a/src/server/Model/Json/CreateCategory.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateCategory - ( CreateCategory(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text (Text) - -data CreateCategory = CreateCategory - { name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/server/Model/Json/CreateIncome.hs b/src/server/Model/Json/CreateIncome.hs deleted file mode 100644 index cf9b1c3..0000000 --- a/src/server/Model/Json/CreateIncome.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateIncome - ( CreateIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -data CreateIncome = CreateIncome - { date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs deleted file mode 100644 index 6ab3a5b..0000000 --- a/src/server/Model/Json/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs deleted file mode 100644 index a10ce39..0000000 --- a/src/server/Model/Json/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) - -data EditCategory = EditCategory - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs deleted file mode 100644 index 9b29379..0000000 --- a/src/server/Model/Json/EditIncome.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditIncome - ( EditIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -import Model.Income (IncomeId) - -data EditIncome = EditIncome - { id :: IncomeId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs deleted file mode 100644 index b7d4d7d..0000000 --- a/src/server/Model/Json/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) -import Model.Payment (PaymentId) - -data EditPayment = EditPayment - { id :: PaymentId - , name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs deleted file mode 100644 index 7e23a84..0000000 --- a/src/server/Model/Json/Income.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Income - ( Income(..) - , fromIncome - ) where - -import Data.Aeson -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Income (IncomeId) -import Model.User (UserId) -import qualified Model.Income as M - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance ToJSON Income - -fromIncome :: M.Income -> Income -fromIncome income = Income (M.id income) (M.userId income) (M.date income) (M.amount income) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs deleted file mode 100644 index 530c3b7..0000000 --- a/src/server/Model/Json/Init.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Init - ( Init(..) - , InitResult(..) - ) where - -import Data.Aeson -import GHC.Generics - -import Model.Json.Category (Category) -import Model.Json.Income (Income) -import Model.Json.Payment (Payment) -import Model.Json.PaymentCategory (PaymentCategory) -import Model.Json.User (User) -import Model.Message.Key (Key) -import Model.User (UserId) - -data Init = Init - { users :: [User] - , me :: UserId - , payments :: [Payment] - , incomes :: [Income] - , categories :: [Category] - , paymentCategories :: [PaymentCategory] - } deriving (Show, Generic) - -instance ToJSON Init - -data InitResult = - InitEmpty - | InitSuccess Init - | InitError Key - deriving (Show, Generic) - -instance ToJSON InitResult diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs deleted file mode 100644 index 0753d7c..0000000 --- a/src/server/Model/Json/MessagePart.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.MessagePart - ( MessagePart(..) - ) where - -import Data.Text (Text) - -import Data.Aeson -import GHC.Generics - -data MessagePart = - Order Int - | Str Text - deriving (Eq, Show, Generic) - -instance FromJSON MessagePart -instance ToJSON MessagePart diff --git a/src/server/Model/Json/Number.hs b/src/server/Model/Json/Number.hs deleted file mode 100644 index 52c9da8..0000000 --- a/src/server/Model/Json/Number.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Number - ( Number(..) - ) where - -import Data.Aeson -import GHC.Generics - -data Number = Number - { number :: Int - } deriving (Show, Generic) - -instance FromJSON Number -instance ToJSON Number diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs deleted file mode 100644 index e406c0f..0000000 --- a/src/server/Model/Json/Payment.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Payment - ( Payment(..) - , fromPayment - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics -import Prelude hiding (id) - -import Model.Frequency -import Model.Payment (PaymentId) -import Model.User (UserId) -import qualified Model.Payment as M - -data Payment = Payment - { id :: PaymentId - , date :: Day - , name :: Text - , cost :: Int - , userId :: UserId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment - -fromPayment :: M.Payment -> Payment -fromPayment payment = - Payment - { id = M.id payment - , date = M.date payment - , name = M.name payment - , cost = M.cost payment - , userId = M.userId payment - , frequency = M.frequency payment - } diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs deleted file mode 100644 index fd97674..0000000 --- a/src/server/Model/Json/PaymentCategory.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.PaymentCategory - ( PaymentCategory(..) - , fromPaymentCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.PaymentCategory as M - -data PaymentCategory = PaymentCategory - { name :: Text - , category :: CategoryId - } deriving (Show, Generic) - -instance ToJSON PaymentCategory - -fromPaymentCategory :: M.PaymentCategory -> PaymentCategory -fromPaymentCategory pc = PaymentCategory (M.name pc) (M.category pc) diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs deleted file mode 100644 index 9dcfe80..0000000 --- a/src/server/Model/Json/Translation.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Translation - ( Translation(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -import Model.Json.MessagePart - -data Translation = Translation - { key :: Text - , message :: [MessagePart] - } deriving (Show, Generic) - -instance FromJSON Translation -instance ToJSON Translation diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs deleted file mode 100644 index c289fe0..0000000 --- a/src/server/Model/Json/User.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.User - ( User(..) - , fromUser - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.User (UserId) -import qualified Model.User as M - -data User = User - { id :: UserId - , name :: Text - , email :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -fromUser :: M.User -> User -fromUser user = User (M.id user) (M.name user) (M.email user) diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs deleted file mode 100644 index 026967f..0000000 --- a/src/server/Model/Message.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Message - ( getMessage - , getParamMessage - , getTranslations - , plural - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key (Key) -import Model.Message.Lang -import Model.Message.Translations (getNonFormattedMessage) -import Model.Message.Parts - -import Model.Json.Translation - -getMessage :: Key -> Text -getMessage = getParamMessage [] - -getParamMessage :: [Text] -> Key -> Text -getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey) - -getTranslations :: [Translation] -getTranslations = (map getTranslation [minBound..]) - -getTranslation :: Key -> Translation -getTranslation translationKey = - Translation - (T.pack . show $ translationKey) - (getParts $ getNonFormattedMessage lang translationKey) - -plural :: Int -> Key -> Key -> Text -plural count singularKey pluralKey = - getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs deleted file mode 100644 index 18f16f0..0000000 --- a/src/server/Model/Message/Key.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Message.Key - ( Key(..) - ) where - -import qualified Data.Aeson as Json -import qualified Data.Text as T - -data Key = - - -- Title - - SharedCost - - -- Sign - - | Email - | SignIn - | SendEmailFail - | InvalidEmail - | UnauthorizedSignIn - | Forbidden - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid - | SignInMailTitle - | SignInMail - | SignInEmailSent - - -- Dates - - | January - | February - | March - | April - | May - | June - | July - | August - | September - | October - | November - | December - - | ShortDate - | ShortMonthAndYear - | LongDate - - -- Search - - | SearchName - | SearchPunctual - | SearchMonthly - - -- Payments - - | PaymentsAreBalanced - | Name - | Cost - | Payer - | Date - | Frequency - | InvalidFrequency - | AddPayment - | ClonePayment - | EditPayment - | PaymentNotDeleted - | Punctual - | Monthly - - | PaymentsTitle - | Payment - | Payments - | Worth - | NoPayment - - | PaymentName - | PaymentCost - | PaymentDate - | PaymentCategory - | PaymentPunctual - | PaymentMonthly - - | Clone - | Edit - | Delete - | ConfirmPaymentDelete - - -- Categories - - | Categories - | NoCategories - | CategoryNotDeleted - | AddCategory - | CloneCategory - | EditCategory - | ConfirmCategoryDelete - | CategoryName - | CategoryColor - | Color - | UsedCategory - - -- Statistics - - | Statistics - | ByMonthsAndMean - | By - | Total - - -- Income - - | CumulativeIncomesSince - | NoIncome - | Income - | MonthlyNetIncomes - | AddIncome - | CloneIncome - | EditIncome - | IncomeNotDeleted - | IncomeAmount - | IncomeDate - | ConfirmIncomeDelete - | Add - - -- Form - - | Empty - | InvalidString - | InvalidDate - | CostMustNotBeNull - | InvalidInt - | InvalidCategory - | InvalidColor - | AlreadyExists - | SmallerIntThan - | GreaterIntThan - - -- Errors - - | CreatePaymentError - | EditPaymentError - | DeletePaymentError - | CreateIncomeError - | EditIncomeError - | DeleteIncomeError - | CreateCategoryError - | EditCategoryError - | DeleteCategoryError - | SignOutError - - -- Dialog - - | Confirm - | Undo - - -- Page not found - - | PageNotFound - - -- Weekly report - - | WeeklyReport - | WeeklyReportEmpty - | PaymentCreated - | PaymentsCreated - | PaymentEdited - | PaymentsEdited - | PaymentDeleted - | PaymentsDeleted - | IncomeCreated - | IncomesCreated - | IncomeEdited - | IncomesEdited - | IncomeDeleted - | IncomesDeleted - | PayedFor - | DidNotPayFor - | IsPayedFrom - | IsNotPayedFrom - - -- Http error - - | BadUrl - | Timeout - | NetworkError - | BadPayload - - deriving (Enum, Bounded, Show) - -instance Json.ToJSON Key where - toJSON = Json.String . T.pack . show diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs deleted file mode 100644 index f515c96..0000000 --- a/src/server/Model/Message/Lang.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Model.Message.Lang - ( Lang(..) - , lang - ) where - -data Lang = - English - | French - -lang :: Lang -lang = French diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs deleted file mode 100644 index d065cf2..0000000 --- a/src/server/Model/Message/Parts.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Parts - ( replaceParts - , getParts - ) where - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T - -import Text.ParserCombinators.Parsec - -import Model.Json.MessagePart - -replaceParts :: [Text] -> Text -> Text -replaceParts values message = - T.concat . map (replacePart values) $ getParts message - -replacePart :: [Text] -> MessagePart -> Text -replacePart _ (Str str) = str -replacePart values (Order n) = - fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values - -getParts :: Text -> [MessagePart] -getParts str = - case parse partsParser "" (T.unpack str) of - Right parts -> parts - Left _ -> [] - -partsParser :: Parser [MessagePart] -partsParser = many partParser - -partParser :: Parser MessagePart -partParser = - (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n)) - <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str)) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs deleted file mode 100644 index 7d26c3f..0000000 --- a/src/server/Model/Message/Translations.hs +++ /dev/null @@ -1,729 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Translations - ( getNonFormattedMessage - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key -import Model.Message.Lang - -getNonFormattedMessage :: Lang -> Key -> Text -getNonFormattedMessage = m - -m :: Lang -> Key -> Text - --- Title - -m l SharedCost = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - --- Sign in - -m l Email = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn = - case l of - English -> "Sign in" - French -> "Connexion" - -m l InvalidEmail = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n'est pas valide." - -m l UnauthorizedSignIn = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n'es pas autorisé à te connecter." - -m l Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SendEmailFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n'avons pas pu t'envoyer le courriel de connexion." - -m l EnterValidEmail = - case l of - English -> "Please enter a valid email address." - French -> "Ton courriel n'est pas valide." - -m l SignInUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignInExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignInInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - -m l SignInMailTitle = - case l of - English -> T.concat ["Sign in to ", m l SharedCost] - French -> T.concat ["Connexion à ", m l SharedCost] - -m l SignInMail = - T.intercalate - "\n" - ( case l of - English -> - [ "Hi {1}," - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l SharedCost - , ":" - ] - , "{2}" - , "" - , "See you soon!" - ] - French -> - [ "Salut {1}," - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l SharedCost - , ":" - ] - , "{2}" - , "" - , "À très vite !" - ] - ) - -m l SignInEmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t'avons envoyé un courriel avec un lien pour te connecter." - --- Date - -m l January = - case l of - English -> "january" - French -> "janvier" - -m l February = - case l of - English -> "february" - French -> "février" - -m l March = - case l of - English -> "march" - French -> "mars" - -m l April = - case l of - English -> "april" - French -> "avril" - -m l May = - case l of - English -> "may" - French -> "mai" - -m l June = - case l of - English -> "june" - French -> "juin" - -m l July = - case l of - English -> "july" - French -> "juillet" - -m l August = - case l of - English -> "august" - French -> "août" - -m l September = - case l of - English -> "september" - French -> "septembre" - -m l October = - case l of - English -> "october" - French -> "octobre" - -m l November = - case l of - English -> "november" - French -> "novembre" - -m l December = - case l of - English -> "december" - French -> "décembre" - -m l ShortDate = - case l of - English -> "{3}-{2}-{1}" - French -> "{1}/{2}/{3}" - -m l ShortMonthAndYear = - case l of - English -> "{2}-{1}" - French -> "{1}/{2}" - -m l LongDate = - case l of - English -> "{2} {1}, {3}" - French -> "{1} {2} {3}" - --- Search - -m l SearchName = - case l of - English -> "Search" - French -> "Recherche" - -m l SearchPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l SearchMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - --- Payments - -m l PaymentsAreBalanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Name = - case l of - English -> "Name" - French -> "Nom" - -m l Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payer = - case l of - English -> "Payer" - French -> "Payeur" - -m l Date = - case l of - English -> "Date" - French -> "Date" - -m l Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l AddPayment = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l ClonePayment = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l EditPayment = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l PaymentNotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n'a pas pu être supprimé." - -m l Punctual = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Monthly = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l PaymentsTitle = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment = - case l of - English -> "payment" - French -> "paiement" - -m l Payments = - case l of - English -> "payments" - French -> "paiements" - -m l Worth = - case l of - English -> "{1} worth {2}" - French -> "{1} comptabilisant {2}" - -m l NoPayment = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l PaymentName = - case l of - English -> "Name" - French -> "Nom" - -m l PaymentCost = - case l of - English -> "Cost" - French -> "Coût" - -m l PaymentDate = - case l of - English -> "Date" - French -> "Date" - -m l PaymentCategory = - case l of - English -> "Category" - French -> "Catégorie" - -m l PaymentPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l PaymentMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l ConfirmPaymentDelete = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Edit = - case l of - English -> "Edit" - French -> "Modifier" - -m l Clone = - case l of - English -> "Clone" - French -> "Cloner" - -m l Delete = - case l of - English -> "Delete" - French -> "Supprimer" - --- Categories - -m l Categories = - case l of - English -> "Categories" - French -> "Catégories" - -m l NoCategories = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l CategoryNotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n'a pas pu être supprimé." - -m l AddCategory = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l CloneCategory = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l EditCategory = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l ConfirmCategoryDelete = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l CategoryName = - case l of - English -> "Name" - French -> "Nom" - -m l CategoryColor = - case l of - English -> "Color" - French -> "Couleur" - -m l Color = - case l of - English -> "Color" - French -> "Couleur" - -m l UsedCategory = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - --- Statistics - -m l Statistics = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l ByMonthsAndMean = - case l of - English -> "Payments by category by month months ({1} on average)" - French -> "Paiements par catégorie par mois (en moyenne {1})" - -m l By = - case l of - English -> "{1}: {2}" - French -> "{1} : {2}" - -m l Total = - case l of - English -> "Total" - French -> "Total" - --- Income - -m l CumulativeIncomesSince = - case l of - English -> "Cumulative incomes since {1}" - French -> "Revenus nets cumulés depuis le {1}" - -m l NoIncome = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income = - case l of - English -> "Income" - French -> "Revenu" - -m l MonthlyNetIncomes = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l AddIncome = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l CloneIncome = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l EditIncome = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l IncomeNotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n'a pas pu être supprimé." - -m l IncomeAmount = - case l of - English -> "Amount" - French -> "Montant" - -m l IncomeDate = - case l of - English -> "Date" - French -> "Date" - -m l ConfirmIncomeDelete = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Add = - case l of - English -> "Add" - French -> "Ajouter" - --- Form error - -m l Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l SmallerIntThan = - case l of - English -> "Integer bigger than {1} or equal required" - French -> "Entier supérieur ou égal à {1} requis" - -m l GreaterIntThan = - case l of - English -> "Integer smaller than {1} or equal required" - French -> "Entier inférieur ou égal à {1} requis" - --- Errors - -m l CreatePaymentError = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l EditPaymentError = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l DeletePaymentError = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l CreateIncomeError = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l EditIncomeError = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l DeleteIncomeError = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l CreateCategoryError = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l EditCategoryError = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l DeleteCategoryError = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l SignOutError = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - --- Dialog - -m l Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Undo = - case l of - English -> "Undo" - French -> "Annuler" - --- Page not found - -m l PageNotFound = - case l of - English -> "Page not found" - French -> "Page introuvable" - --- Weekly report - -m l WeeklyReport = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" - -m l WeeklyReportEmpty = - case l of - English -> "No activity the previous week." - French -> "Pas d'activité la semaine passée." - -m l PaymentCreated = - case l of - English -> "{1} payment created:" - French -> "{1} paiement créé :" - -m l PaymentsCreated = - case l of - English -> "{1} payments created:" - French -> "{1} paiements créés :" - -m l PaymentEdited = - case l of - English -> "{1} payment edited:" - French -> "{1} paiement modifié :" - -m l PaymentsEdited = - case l of - English -> "{1} payments edited:" - French -> "{1} paiements modifiés :" - -m l PaymentDeleted = - case l of - English -> "{1} payment deleted:" - French -> "{1} paiement supprimé :" - -m l PaymentsDeleted = - case l of - English -> "{1} payments deleted:" - French -> "{1} paiements supprimés :" - -m l IncomeCreated = - case l of - English -> "{1} income created:" - French -> "{1} revenu créé :" - -m l IncomesCreated = - case l of - English -> "{1} incomes created:" - French -> "{1} revenus créés :" - -m l IncomeEdited = - case l of - English -> "{1} income edited:" - French -> "{1} revenu modifié :" - -m l IncomesEdited = - case l of - English -> "{1} incomes edited:" - French -> "{1} revenus modifiés :" - -m l IncomeDeleted = - case l of - English -> "{1} income deleted:" - French -> "{1} revenu supprimé :" - -m l IncomesDeleted = - case l of - English -> "{1} incomes deleted:" - French -> "{1} revenus supprimés :" - -m l PayedFor = - case l of - English -> "{1} payed {2} for “{3}” at {4}" - French -> "{1} a payé {2} concernant « {3} » le {4}" - -m l DidNotPayFor = - case l of - English -> "{1} didn't pay {2} for “{3}” at {4}" - French -> "{1} n'a pas payé {2} concernant « {3} » le {4}" - -m l IsPayedFrom = - case l of - English -> "{1} is payed {2} of net monthly income from {3}" - French -> "{1} est payé {2} net par mois à partir du {3}" - -m l IsNotPayedFrom = - case l of - English -> "{1} isn't payed {2} of net monthly income from {3}" - French -> "{1} n'est pas payé {2} net par mois à partir du {3}" - --- Http error - -m l BadUrl = - case l of - English -> "URL not valid" - French -> "l'URL n'est pas valide" - -m l Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n'est pas accessible" - -m l BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/src/server/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/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5414d18..5b576c5 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment - ( PaymentId - , Payment(..) + ( Payment(..) , find , list , listMonthly @@ -13,7 +13,6 @@ module Model.Payment , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time (UTCTime) @@ -24,29 +23,19 @@ import Database.SQLite.Simple.ToField (ToField(toField)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Frequency +import Common.Model.Frequency +import Common.Model.Payment (Payment(..)) +import Common.Model.User (UserId) +import Common.Model.Payment (PaymentId) + +import Model.Frequency () import Model.Query (Query(Query)) -import Model.User (UserId) import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type PaymentId = Int64 - -data Payment = Payment - { id :: PaymentId - , userId :: UserId - , name :: Text - , cost :: Int - , date :: Day - , frequency :: Frequency - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Payment where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt instance FromRow Payment where fromRow = Payment <$> @@ -62,12 +51,12 @@ instance FromRow Payment where instance ToRow Payment where toRow p = - [ toField (userId p) - , toField (name p) - , toField (cost p) - , toField (date p) - , toField (frequency p) - , toField (createdAt 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) @@ -92,13 +81,13 @@ listMonthly = ) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create paymentUserId paymentName paymentCost paymentDate paymentFrequency = +create userId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do now <- getCurrentTime SQLite.execute conn "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" - (paymentUserId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -112,13 +101,13 @@ createMany payments = ) editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequency = +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 userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute @@ -133,13 +122,13 @@ editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequ ) deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn paymentUserId paymentId = +deleteOwn userId paymentId = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs index 7c504dc..6e1d304 100644 --- a/src/server/Model/PaymentCategory.hs +++ b/src/server/Model/PaymentCategory.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - , list + ( list , listByCategory , save ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) 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 Model.Category (CategoryId) -import Model.Query (Query(Query)) -import qualified Utils.Text as T - -type PaymentCategoryId = Int64 +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T -data PaymentCategory = PaymentCategory - { id :: PaymentCategoryId - , name :: Text - , category :: CategoryId - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index c8a0d53..eb78a69 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User - ( UserId - , User(..) - , list - , getUser - , findUser + ( list + , get , createUser , deleteUser ) where -import Data.Int (Int64) -import Data.List (find) 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 Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) - -type UserId = Int64 +import Common.Model (UserId, User(..)) -data User = User - { id :: UserId - , creation :: UTCTime - , email :: Text - , name :: Text - } deriving Show +import Model.Query (Query(Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field @@ -37,15 +25,12 @@ instance FromRow User where list :: Query [User] list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") -getUser :: Text -> Query (Maybe User) -getUser userEmail = +get :: Text -> Query (Maybe User) +get userEmail = Query (\conn -> listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -findUser :: UserId -> [User] -> Maybe User -findUser userId = find ((==) userId . id) - createUser :: Text -> Text -> Query UserId createUser userEmail userName = Query (\conn -> do diff --git a/src/server/Secure.hs b/src/server/Secure.hs index da48878..f427304 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -11,11 +11,12 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import Model.Message (getMessage) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + import Model.Query (Query) -import Model.User (User) import qualified LoginSession -import qualified Model.Message.Key as Key import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -31,16 +32,16 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.UnauthorizedSignIn + html . fromStrict . Message.get $ Key.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.Forbidden + 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.getUser (SignIn.email signIn) + User.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/src/server/Utils/Text.hs b/src/server/Utils/Text.hs deleted file mode 100644 index 5ed77e4..0000000 --- a/src/server/Utils/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Utils.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs index 4a247e9..97457c7 100644 --- a/src/server/Utils/Time.hs +++ b/src/server/Utils/Time.hs @@ -2,7 +2,6 @@ module Utils.Time ( belongToCurrentMonth , belongToCurrentWeek , timeToDay - , monthToKey ) where import Data.Time.Clock (UTCTime, getCurrentTime) @@ -10,9 +9,6 @@ import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate (toWeekDate) -import Model.Message.Key (Key) -import qualified Model.Message.Key as K - belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time @@ -27,18 +23,3 @@ belongToCurrentWeek time = do timeToDay :: UTCTime -> IO Day timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time - -monthToKey :: Int -> Maybe Key -monthToKey 1 = Just K.January -monthToKey 2 = Just K.February -monthToKey 3 = Just K.March -monthToKey 4 = Just K.April -monthToKey 5 = Just K.May -monthToKey 6 = Just K.June -monthToKey 7 = Just K.July -monthToKey 8 = Just K.August -monthToKey 9 = Just K.September -monthToKey 10 = Just K.October -monthToKey 11 = Just K.November -monthToKey 12 = Just K.December -monthToKey _ = Nothing diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs deleted file mode 100644 index 354d46a..0000000 --- a/src/server/View/Format.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Format - ( price - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) - -import Conf (Conf) -import qualified Conf - -price :: Conf -> Int -> Text -price conf amount = T.concat [number amount, " ", Conf.currency conf] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index c7d40d8..12c4f34 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -6,10 +6,11 @@ module View.Mail.SignIn import Data.Text (Text) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.User (User(..)) + import Conf (Conf) -import Model.Message -import Model.Message.Key -import Model.User (User(..)) import qualified Conf as Conf import qualified Model.Mail as M @@ -18,6 +19,6 @@ mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = (getMessage SignInMailTitle) - , M.plainBody = getParamMessage [name user, url] SignInMail + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index 1a80b95..0bafb70 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -9,38 +9,34 @@ import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime) import qualified Data.Map as M import qualified Data.Text as T -import Resource (Status(..), groupByStatus, statuses) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model.User as User +import qualified Common.View.Format as Format -import Model.Income (Income) import Model.Mail (Mail(Mail)) -import Model.Message (getMessage, getParamMessage, plural) -import Model.Payment (Payment) -import Model.User (findUser) -import Model.User (User, UserId) -import qualified Model.Income as Income +import Model.Payment () +import qualified Model.Income () import qualified Model.Mail as M -import qualified Model.Message.Key as K -import qualified Model.Payment as Payment -import qualified Model.User as User - +import Resource (Status(..), groupByStatus, statuses) import Conf (Conf) import qualified Conf as Conf -import qualified View.Format as Format - -import Utils.Time (monthToKey) - 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 [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport] + , 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) } @@ -48,7 +44,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - getMessage K.WeeklyReportEmpty + Message.get Key.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -57,65 +53,45 @@ body conf users paymentsByStatus incomesByStatus = paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = - section - (plural (length payments) singleKey pluralKey) - (map (payedFor status conf users) . sortOn Payment.date $ payments) - where (singleKey, pluralKey) = - case status of - Created -> (K.PaymentCreated, K.PaymentsCreated) - Edited -> (K.PaymentEdited, K.PaymentsEdited) - Deleted -> (K.PaymentDeleted, K.PaymentsDeleted) + 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 = - getParamMessage - [ formatUserName (Payment.userId payment) users - , Format.price conf . Payment.cost $ payment - , Payment.name payment - , formatDay $ Payment.date payment - ] - ( case status of - Created -> K.PayedFor - Edited -> K.PayedFor - Deleted -> K.DidNotPayFor - ) + 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 - (plural (length incomes) singleKey pluralKey) - (map (isPayedFrom status conf users) . sortOn Income.date $ incomes) - where (singleKey, pluralKey) = - case status of - Created -> (K.IncomeCreated, K.IncomesCreated) - Edited -> (K.IncomeEdited, K.IncomesEdited) - Deleted -> (K.IncomeDeleted, K.IncomesDeleted) + 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 = - getParamMessage - [ formatUserName (Income.userId income) users - , Format.price conf . Income.amount $ income - , formatDay $ Income.date income - ] - ( case status of - Created -> K.IsPayedFrom - Edited -> K.IsPayedFrom - Deleted -> K.IsNotPayedFrom - ) + 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 . findUser userId - -formatDay :: Day -> Text -formatDay d = - let (year, month, day) = toGregorian d - in getParamMessage - [ T.pack . show $ day - , fromMaybe "−" . fmap getMessage . monthToKey $ month - , T.pack . show $ year - ] - K.LongDate +formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId section :: Text -> [Text] -> Text section title items = diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 5a2e4f8..1c072a4 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -16,29 +16,24 @@ import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text (renderHtml) -import Design.Global (globalDesign) +import qualified Common.Message as Message +import Common.Model.InitResult (InitResult) +import qualified Common.Message.Key as Key -import Model.Message -import Model.Json.Conf -import Model.Json.Init (InitResult) -import Model.Message.Key (Key(SharedCost)) +import Design.Global (globalDesign) -page :: Conf -> InitResult -> Text -page conf initResult = +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 $ getMessage SharedCost) - script ! src "javascripts/client.js" $ "" - jsonScript "translations" getTranslations - jsonScript "conf" conf - jsonScript "result" initResult + 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 - body $ do - script ! src "javascripts/main.js" $ "" jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = |