diff options
Diffstat (limited to 'src/server')
33 files changed, 598 insertions, 115 deletions
diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs new file mode 100644 index 0000000..19109a3 --- /dev/null +++ b/src/server/Controller/Category.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Category + ( create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty hiding (delete) + +import Json (jsonId) +import Model.Database +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 Secure + +create :: Json.CreateCategory -> ActionM () +create (Json.CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . runDb $ Category.create name color) >>= jsonId + ) + +edit :: Json.EditCategory -> ActionM () +edit (Json.EditCategory categoryId name color) = + Secure.loggedAction (\_ -> do + updated <- liftIO . runDb $ Category.edit categoryId name color + if updated + then status ok200 + else status badRequest400 + ) + +delete :: Text -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . runDb $ do + paymentCategories <- PaymentCategory.listByCategory (textToKey categoryId) + if null paymentCategories + then Category.delete (textToKey categoryId) + else return False + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.pack . show $ Key.CategoryNotDeleted + ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index abb3b17..96d0a49 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -1,18 +1,18 @@ module Controller.Index - ( getIndex + ( get , signOut ) where import Control.Monad.IO.Class (liftIO) -import Web.Scotty +import Web.Scotty hiding (get) import Network.HTTP.Types.Status (ok200) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Database.Persist hiding (Key) +import Database.Persist hiding (Key, get) import Conf (Conf(..)) import qualified LoginSession @@ -28,8 +28,8 @@ import Model.Init (getInit) import View.Page (page) -getIndex :: Conf -> Maybe Text -> ActionM () -getIndex conf mbToken = do +get :: Conf -> Maybe Text -> ActionM () +get conf mbToken = do initResult <- case mbToken of Just token -> do userOrError <- validateSignIn conf token diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index 9155a78..e3f1082 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -23,6 +23,7 @@ import Json (jsonId) import Model.Database import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Json.CreatePayment as Json import qualified Model.Json.EditPayment as Json @@ -33,15 +34,27 @@ list = ) create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date frequency) = +create (Json.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . runDb $ Payment.create (entityKey user) name cost date frequency) >>= jsonId + (liftIO . runDb $ do + PaymentCategory.set name category + Payment.create (entityKey user) name cost date frequency + ) >>= jsonId ) editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date frequency) = +editOwn (Json.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do - updated <- liftIO . runDb $ Payment.editOwn (entityKey user) paymentId name cost date frequency + updated <- liftIO . runDb $ do + mbPayment <- fmap entityVal <$> Payment.find paymentId + case mbPayment of + Just payment -> do + edited <- Payment.editOwn (entityKey user) paymentId name cost date frequency + if edited + then PaymentCategory.edit (paymentName payment) name category >> return True + else return edited + _ -> + return False if updated then status ok200 else status badRequest400 diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs index 1baab18..d8604ac 100644 --- a/src/server/Controller/User.hs +++ b/src/server/Controller/User.hs @@ -2,7 +2,6 @@ module Controller.User ( getUsers - , whoAmI ) where import Web.Scotty @@ -12,16 +11,10 @@ import Control.Monad.IO.Class (liftIO) import qualified Secure import Model.Database -import qualified Model.User as U +import qualified Model.User as User getUsers :: ActionM () getUsers = Secure.loggedAction (\_ -> - (liftIO $ map U.getJsonUser <$> runDb U.getUsers) >>= json - ) - -whoAmI :: ActionM () -whoAmI = - Secure.loggedAction (\user -> - json (U.getJsonUser user) + (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json ) diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs index a532ac8..4e2b8cc 100644 --- a/src/server/Design/Constants.hs +++ b/src/server/Design/Constants.hs @@ -2,13 +2,13 @@ module Design.Constants where import Clay -iconFontSize :: Size Abs +iconFontSize :: Size LengthUnit iconFontSize = px 32 -radius :: Size Abs +radius :: Size LengthUnit radius = px 3 -blockPadding :: Size Abs +blockPadding :: Size LengthUnit blockPadding = px 15 blockPercentWidth :: Double diff --git a/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs index 2320c45..4678633 100644 --- a/src/server/Design/Dialog.hs +++ b/src/server/Design/Dialog.hs @@ -14,8 +14,11 @@ design = do ".content" ? do minWidth (px 270) - ".paymentDialog" ? do - ".radioGroup" ? ".title" ? display none + ".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/src/server/Design/Form.hs b/src/server/Design/Form.hs index 3043125..ebb8ac8 100644 --- a/src/server/Design/Form.hs +++ b/src/server/Design/Form.hs @@ -18,6 +18,10 @@ design = do let inputPaddingBottom = 3 let inputZIndex = 1 + label ? do + cursor pointer + color Color.silver + ".textInput" ? do position relative marginBottom (em 1.5) @@ -44,7 +48,6 @@ design = do position absolute top (px inputTop) left (px 0) - color Color.silver transition "all" (sec 0.2) easeIn (sec 0) button ? do @@ -68,6 +71,15 @@ design = do 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) @@ -90,11 +102,29 @@ design = do width (px 30) margin (px 0) (px (-15)) (px 0) (px (-15)) - label ? cursor pointer - "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/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index f25cf05..869616d 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -17,13 +17,12 @@ import Data.Monoid ((<>)) import Design.Constants import Design.Color as Color -import qualified Clay.Display as D clearFix :: Css clearFix = after & do content (stringContent "") - display D.table + display displayTable clear both button :: Color -> Color -> Size a -> (Color -> Color) -> Css @@ -40,7 +39,7 @@ button backgroundCol textCol h focusOp = do hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) -iconButton :: Color -> Color -> Size Abs -> (Color -> Color) -> Css +iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css iconButton backgroundCol textCol h focusOp = do button backgroundCol textCol h focusOp i <> span ? do diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/LoggedIn.hs index 2899fa4..4a21832 100644 --- a/src/server/Design/LoggedIn.hs +++ b/src/server/Design/LoggedIn.hs @@ -7,16 +7,39 @@ module Design.LoggedIn import Clay import qualified Design.LoggedIn.Home as Home -import qualified Design.LoggedIn.Income as Income import qualified Design.LoggedIn.Stat as Stat import qualified Design.LoggedIn.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 ".home" ? Home.design - ".income" ? Income.design ".stat" ? Stat.design Table.design - ".textual" ? do + ".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/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/LoggedIn/Home/Table.hs index 73ced3a..cb46ac9 100644 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ b/src/server/Design/LoggedIn/Home/Table.hs @@ -11,17 +11,20 @@ import qualified Design.Media as Media design :: Css design = do ".cell" ? do - ".category" & do - Media.tabletDesktop $ width (pct 36) + ".name" & do + Media.tabletDesktop $ width (pct 30) ".cost" & do - Media.tabletDesktop $ width (pct 15) + Media.tabletDesktop $ width (pct 10) ".user" & do - Media.tabletDesktop $ width (pct 20) + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) ".date" & do - Media.tabletDesktop $ width (pct 20) + Media.tabletDesktop $ width (pct 15) Media.desktop $ do ".shortDate" ? display none ".longDate" ? display inline diff --git a/src/server/Design/LoggedIn/Income.hs b/src/server/Design/LoggedIn/Income.hs deleted file mode 100644 index c44c67b..0000000 --- a/src/server/Design/LoggedIn/Income.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Income - ( design - ) where - -import Clay - -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 = - ".monthlyNetIncomes" ? do - - h1 ? do - Media.tabletDesktop $ float floatLeft - - ".addIncome" ? 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) diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs index 1af5e2b..44b001a 100644 --- a/src/server/Design/LoggedIn/Table.hs +++ b/src/server/Design/LoggedIn/Table.hs @@ -7,7 +7,6 @@ module Design.LoggedIn.Table import Data.Monoid ((<>)) import Clay -import qualified Clay.Display as D import Design.Color as Color import qualified Design.Media as Media @@ -19,7 +18,7 @@ design = do textAlign (alignSide sideCenter) ".lines" ? do - Media.tabletDesktop $ display D.table + Media.tabletDesktop $ display displayTable width (pct 100) textAlign (alignSide (sideCenter)) diff --git a/src/server/Design/Media.hs b/src/server/Design/Media.hs index d61a8e1..77220ee 100644 --- a/src/server/Design/Media.hs +++ b/src/server/Design/Media.hs @@ -29,8 +29,8 @@ desktop = query [Media.minWidth tabletDesktopLimit] query :: [Feature] -> Css -> Css query = Clay.query Media.screen -mobileTabletLimit :: Size Abs +mobileTabletLimit :: Size LengthUnit mobileTabletLimit = (px 520) -tabletDesktopLimit :: Size Abs +tabletDesktopLimit :: Size LengthUnit tabletDesktopLimit = (px 950) diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs index 0d1eb35..5cde3e9 100644 --- a/src/server/Job/WeeklyReport.hs +++ b/src/server/Job/WeeklyReport.hs @@ -7,7 +7,7 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Model.Database (runDb) import qualified Model.Payment as Payment import qualified Model.Income as Income -import Model.User (getUsers) +import qualified Model.User as User import SendMail @@ -25,7 +25,7 @@ weeklyReport conf mbLastExecution = do (,,) <$> Payment.modifiedDuring lastExecution now <*> Income.modifiedDuring lastExecution now <*> - getUsers + User.list _ <- sendMail (mail conf users payments incomes lastExecution now) return () return now diff --git a/src/server/Main.hs b/src/server/Main.hs index 2ce8115..b7764c9 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -8,10 +8,11 @@ import Job.Daemon (runDaemons) import qualified Data.Text.Lazy as LT -import Controller.Index -import Controller.SignIn -import Controller.Payment as Payment -import Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.SignIn as SignIn +import qualified Controller.Payment as Payment +import qualified Controller.Income as Income +import qualified Controller.Category as Category import Model.Database (runMigrations) @@ -27,14 +28,14 @@ main = do get "/" $ do signInToken <- mbParam "signInToken" - getIndex conf signInToken + Index.get conf signInToken post "/signIn" $ do email <- param "email" - signIn conf email + SignIn.signIn conf email post "/signOut" $ - signOut conf + Index.signOut conf post "/payment" $ jsonData >>= Payment.create @@ -56,5 +57,15 @@ main = 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/src/server/Model/Category.hs b/src/server/Model/Category.hs new file mode 100644 index 0000000..50c3622 --- /dev/null +++ b/src/server/Model/Category.hs @@ -0,0 +1,56 @@ +module Model.Category + ( list + , create + , edit + , delete + ) where + +import Data.Text (Text) +import Data.Maybe (isJust) +import Data.Time.Clock (getCurrentTime) + +import Control.Monad.IO.Class (liftIO) + +import Database.Persist hiding (delete) + +import Model.Database +import qualified Model.Json.Category as Json + +list :: Persist [Json.Category] +list = map getJsonCategory <$> selectList [ CategoryDeletedAt ==. Nothing ] [] + +getJsonCategory :: Entity Category -> Json.Category +getJsonCategory categoryEntity = + Json.Category (entityKey categoryEntity) (categoryName category) (categoryColor category) + where category = entityVal categoryEntity + +create :: Text -> Text -> Persist CategoryId +create name color = do + now <- liftIO getCurrentTime + insert (Category name color now Nothing Nothing) + +edit :: CategoryId -> Text -> Text -> Persist Bool +edit categoryId name color = do + mbCategory <- get categoryId + if isJust mbCategory + then do + now <- liftIO getCurrentTime + update categoryId + [ CategoryEditedAt =. Just now + , CategoryName =. name + , CategoryColor =. color + ] + return True + else + return False + +delete :: CategoryId -> Persist Bool +delete categoryId = do + mbCategory <- get categoryId + if isJust mbCategory + then do + now <- liftIO getCurrentTime + update categoryId [CategoryDeletedAt =. Just now] + return True + else + return False diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 7f8326e..ba302de 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -46,6 +46,20 @@ Payment editedAt UTCTime Maybe deletedAt UTCTime Maybe deriving Show +Category + name Text + color Text + createdAt UTCTime + editedAt UTCTime Maybe + deletedAt UTCTime Maybe + deriving Show +PaymentCategory + name Text + category CategoryId + createdAt UTCTime + editedAt UTCTime Maybe + UniqPaymentCategoryName name + deriving Show SignIn token Text creation UTCTime diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index b7dd11c..ff6accd 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,6 +1,5 @@ module Model.Income - ( getJsonIncome - , getIncomes + ( list , create , editOwn , deleteOwn @@ -17,14 +16,14 @@ import Database.Persist import Model.Database import qualified Model.Json.Income as Json +list :: Persist [Json.Income] +list = map getJsonIncome <$> selectList [IncomeDeletedAt ==. Nothing] [] + getJsonIncome :: Entity Income -> Json.Income getJsonIncome incomeEntity = Json.Income (entityKey incomeEntity) (incomeUserId income) (incomeDate income) (incomeAmount income) where income = entityVal incomeEntity -getIncomes :: Persist [Entity Income] -getIncomes = selectList [IncomeDeletedAt ==. Nothing] [] - create :: UserId -> Day -> Int -> Persist IncomeId create userId date amount = do now <- liftIO getCurrentTime diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 09ac627..7610b25 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -10,22 +10,21 @@ import Database.Persist import Model.Database -import Model.Json.Init (Init, Init(Init)) +import Model.Json.Init (Init) import qualified Model.Payment as Payment -import Model.User (getUsers, getJsonUser) -import Model.Income (getIncomes, getJsonIncome) +import qualified Model.User as User +import qualified Model.Income as Income +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Json.Init as Init getInit :: Entity User -> Persist Init getInit user = - liftIO . runDb $ do - users <- getUsers - payments <- Payment.list - incomes <- getIncomes - return $ Init - { Init.users = map getJsonUser users - , Init.me = entityKey user - , Init.payments = payments - , Init.incomes = map getJsonIncome incomes - } + liftIO . runDb $ Init.Init <$> + (map User.getJson <$> User.list) <*> + (return . entityKey $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs new file mode 100644 index 0000000..daad4c2 --- /dev/null +++ b/src/server/Model/Json/Category.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.Category + ( Category(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +import Model.Database (CategoryId) + +data Category = Category + { id :: CategoryId + , name :: Text + , color :: Text + } deriving (Show, Generic) + +instance ToJSON Category diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs new file mode 100644 index 0000000..fffc882 --- /dev/null +++ b/src/server/Model/Json/CreateCategory.hs @@ -0,0 +1,17 @@ +{-# 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/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs index 4ba9e1a..5bc6b47 100644 --- a/src/server/Model/Json/CreatePayment.hs +++ b/src/server/Model/Json/CreatePayment.hs @@ -10,12 +10,14 @@ import Data.Aeson import Data.Time.Calendar (Day) import Data.Text (Text) +import Model.Database (CategoryId) import Model.Frequency (Frequency) data CreatePayment = CreatePayment { name :: Text , cost :: Int , date :: Day + , category :: CategoryId , frequency :: Frequency } deriving (Show, Generic) diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs new file mode 100644 index 0000000..bda3418 --- /dev/null +++ b/src/server/Model/Json/EditCategory.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.EditCategory + ( EditCategory(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +import Model.Database (CategoryId) + +data EditCategory = EditCategory + { id :: CategoryId + , name :: Text + , color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs index 4e91000..35f44e5 100644 --- a/src/server/Model/Json/EditPayment.hs +++ b/src/server/Model/Json/EditPayment.hs @@ -11,13 +11,14 @@ import Data.Time.Calendar (Day) import Data.Text (Text) import Model.Frequency (Frequency) -import Model.Database (PaymentId) +import Model.Database (PaymentId, CategoryId) data EditPayment = EditPayment { id :: PaymentId , name :: Text , cost :: Int , date :: Day + , category :: CategoryId , frequency :: Frequency } deriving (Show, Generic) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs index 5e6d2a2..b9f7f40 100644 --- a/src/server/Model/Json/Init.hs +++ b/src/server/Model/Json/Init.hs @@ -13,6 +13,8 @@ import Model.Database (UserId) import Model.Json.User (User) import Model.Json.Payment (Payment) import Model.Json.Income (Income) +import Model.Json.Category (Category) +import Model.Json.PaymentCategory (PaymentCategory) import Model.Message.Key (Key) data Init = Init @@ -20,6 +22,8 @@ data Init = Init , me :: UserId , payments :: [Payment] , incomes :: [Income] + , categories :: [Category] + , paymentCategories :: [PaymentCategory] } deriving (Show, Generic) instance ToJSON Init diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs new file mode 100644 index 0000000..edd4388 --- /dev/null +++ b/src/server/Model/Json/PaymentCategory.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.PaymentCategory + ( PaymentCategory(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +import Model.Database (CategoryId) + +data PaymentCategory = PaymentCategory + { name :: Text + , category :: CategoryId + } deriving (Show, Generic) + +instance ToJSON PaymentCategory diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index d00d8b8..36b3ba0 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -77,6 +77,8 @@ data Key = | PaymentName | PaymentCost + | PaymentDate + | PaymentCategory | PaymentPunctual | PaymentMonthly @@ -85,6 +87,20 @@ data Key = | Delete | ConfirmPaymentDelete + -- Categories + + | Categories + | NoCategories + | CategoryNotDeleted + | AddCategory + | CloneCategory + | EditCategory + | ConfirmCategoryDelete + | CategoryName + | CategoryColor + | Color + | UsedCategory + -- Statistics | Statistics @@ -94,6 +110,7 @@ data Key = -- Income | CumulativeIncomesSince + | NoIncome | Income | MonthlyNetIncomes | AddIncome @@ -101,6 +118,7 @@ data Key = | EditIncome | IncomeNotDeleted | IncomeAmount + | IncomeDate | ConfirmIncomeDelete | Add @@ -110,6 +128,7 @@ data Key = | InvalidString | InvalidDate | InvalidInt + | InvalidCategory | SmallerIntThan | GreaterIntThan @@ -121,6 +140,9 @@ data Key = | CreateIncomeError | EditIncomeError | DeleteIncomeError + | CreateCategoryError + | EditCategoryError + | DeleteCategoryError | SignOutError -- Dialog @@ -128,6 +150,10 @@ data Key = | Confirm | Undo + -- Page not found + + | PageNotFound + -- Weekly report | WeeklyReport @@ -151,9 +177,10 @@ data Key = -- Http error + | BadUrl | Timeout | NetworkError - | UnexpectedPayload + | BadPayload deriving (Enum, Bounded, Show) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index 23e3a6c..6565344 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -295,6 +295,63 @@ m l NoPayment = English -> "No payment found from your search criteria." French -> "Aucun paiement ne correspond à vos critères de recherches." +-- 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 utilisée actuellement" + -- Statistics m l Statistics = @@ -322,6 +379,16 @@ m l PaymentCost = 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" @@ -359,6 +426,11 @@ m l CumulativeIncomesSince = 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" @@ -394,6 +466,11 @@ m l IncomeAmount = 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 ?" @@ -426,6 +503,11 @@ m l InvalidInt = English -> "Integer required" French -> "Entier requis" +m l InvalidCategory = + case l of + English -> "Invalid category" + French -> "Catégorie invalide" + m l SmallerIntThan = case l of English -> "Integer bigger than {1} or equal required" @@ -468,6 +550,21 @@ m l DeleteIncomeError = 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" @@ -485,6 +582,13 @@ m l Undo = 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 = @@ -579,6 +683,11 @@ m l IsNotPayedFrom = -- 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" @@ -589,7 +698,7 @@ m l NetworkError = English -> "Network can not be reached" French -> "Le serveur n'est pas accessible" -m l UnexpectedPayload = +m l BadPayload = case l of - English -> "Unexpected payload server error" - French -> "Contenu inattendu du en provenance du serveur" + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index ac6cf0a..d8caaa8 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Model.Payment - ( list + ( find + , list , listMonthly , create , editOwn @@ -22,11 +23,11 @@ import Model.Database import Model.Frequency import qualified Model.Json.Payment as P +find :: PaymentId -> Persist (Maybe (Entity Payment)) +find paymentId = selectFirst [ PaymentId ==. paymentId ] [] + list :: Persist [P.Payment] -list = - map getJsonPayment <$> selectList - [ PaymentDeletedAt ==. Nothing ] - [] +list = map getJsonPayment <$> selectList [ PaymentDeletedAt ==. Nothing ] [] listMonthly :: Persist [Entity Payment] listMonthly = diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs new file mode 100644 index 0000000..6df77e2 --- /dev/null +++ b/src/server/Model/PaymentCategory.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.PaymentCategory + ( list + , listByCategory + , set + , edit + , delete + ) where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import qualified Data.Text as T + +import Control.Monad.IO.Class (liftIO) + +import Database.Persist + +import Model.Database +import qualified Model.Json.PaymentCategory as Json +import qualified Utils.Text as T + +list :: Persist [Json.PaymentCategory] +list = map getJsonPaymentCategory <$> selectList [] [] + +listByCategory :: CategoryId -> Persist [Entity PaymentCategory] +listByCategory category = selectList [ PaymentCategoryCategory ==. category ] [] + +getJsonPaymentCategory :: Entity PaymentCategory -> Json.PaymentCategory +getJsonPaymentCategory entity = + Json.PaymentCategory (paymentCategoryName pc) (paymentCategoryCategory pc) + where pc = entityVal entity + +set :: Text -> CategoryId -> Persist () +set name category = edit name name category + +edit :: Text -> Text -> CategoryId -> Persist () +edit oldName newName category = do + now <- liftIO getCurrentTime + mbPaymentCategory <- selectFirst [PaymentCategoryName ==. (formatPaymentName oldName)] [] + if isJust mbPaymentCategory + then + updateWhere + [ PaymentCategoryName ==. (formatPaymentName oldName) ] + [ PaymentCategoryName =. (formatPaymentName newName) + , PaymentCategoryCategory =. category + , PaymentCategoryEditedAt =. Just now + ] + else do + _ <- insert $ PaymentCategory (formatPaymentName newName) category now Nothing + return () + +formatPaymentName :: Text -> Text +formatPaymentName = T.unaccent . T.toLower diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index 696ef4f..ab39822 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,8 +1,8 @@ module Model.User - ( getUsers + ( list , getUser + , getJson , findUser - , getJsonUser , createUser , deleteUser ) where @@ -18,8 +18,8 @@ import Database.Persist import Model.Database import qualified Model.Json.User as Json -getUsers :: Persist [Entity User] -getUsers = selectList [] [Desc UserCreation] +list :: Persist [Entity User] +list = selectList [] [Desc UserCreation] getUser :: Text -> Persist (Maybe (Entity User)) getUser email = selectFirst [UserEmail ==. email] [] @@ -27,8 +27,8 @@ getUser email = selectFirst [UserEmail ==. email] [] findUser :: UserId -> [Entity User] -> Maybe User findUser i = fmap entityVal . find ((==) i . entityKey) -getJsonUser :: Entity User -> Json.User -getJsonUser userEntity = +getJson :: Entity User -> Json.User +getJson userEntity = let user = entityVal userEntity in Json.User (entityKey userEntity) (userName user) (userEmail user) diff --git a/src/server/Utils/Text.hs b/src/server/Utils/Text.hs new file mode 100644 index 0000000..5ed77e4 --- /dev/null +++ b/src/server/Utils/Text.hs @@ -0,0 +1,41 @@ +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/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index f76fb0e..e33459c 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -48,7 +48,7 @@ body conf users paymentsByStatus incomesByStatus = then getMessage K.WeeklyReportEmpty else - T.intercalate "\n\n" . catMaybes . concat $ + 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 ] @@ -119,6 +119,6 @@ section :: Text -> [Text] -> Text section title items = T.concat [ title - , "\n" + , "\n\n" , T.unlines . map (" - " <>) $ items ] |