From a48e79e2f7c1ab1ffb52b86ef9e900c75c5d023b Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Sep 2015 23:57:16 +0200 Subject: Adding UI income read-only --- src/server/Controller/Index.hs | 12 ++-- src/server/Controller/Payment.hs | 55 +++++++++--------- src/server/Controller/SignIn.hs | 12 ++-- src/server/Controller/User.hs | 31 +++++++--- src/server/Design/Global.hs | 97 +++++++++++++++++++------------- src/server/Main.hs | 39 ++++++------- src/server/Model/Mail.hs | 1 - src/server/Model/Message/Key.hs | 9 ++- src/server/Model/Message/Translations.hs | 72 ++++++++++++++++-------- src/server/SendMail.hs | 8 +-- src/server/View/Mail/SignIn.hs | 24 +------- 11 files changed, 194 insertions(+), 166 deletions(-) (limited to 'src/server') diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 17f5ae9..da67051 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -1,6 +1,6 @@ module Controller.Index - ( getIndexAction - , signOutAction + ( getIndex + , signOut ) where import Web.Scotty @@ -11,10 +11,10 @@ import qualified LoginSession import View.Page (page) -getIndexAction :: ActionM () -getIndexAction = html page +getIndex :: ActionM () +getIndex = html page -signOutAction :: ActionM () -signOutAction = do +signOut :: ActionM () +signOut = do LoginSession.delete status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index 85e2a87..02c8a8e 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Controller.Payment - ( getPaymentsAction - , getMonthlyPaymentsAction - , createPaymentAction - , deletePaymentAction - , getTotalPaymentsAction - , getPaymentsCountAction + ( getPayments + , getMonthlyPayments + , createPayment + , deletePayment + , getTotalPayments + , getPaymentsCount ) where import Web.Scotty @@ -22,40 +22,39 @@ import qualified Data.Aeson.Types as Json import qualified Secure +import Json (jsonObject) + import Model.Database -import Model.Payment +import qualified Model.Payment as P import Model.Frequency import Model.Json.Number import qualified Model.Json.PaymentId as JP import Model.Message import Model.Message.Key (Key(PaymentNotDeleted)) - -import Json (jsonObject) - -getPaymentsAction :: Int -> Int -> ActionM () -getPaymentsAction page perPage = +getPayments :: Int -> Int -> ActionM () +getPayments page perPage = Secure.loggedAction (\_ -> do - (liftIO $ runDb (getPunctualPayments page perPage)) >>= json + (liftIO $ runDb (P.getPunctualPayments page perPage)) >>= json ) -getMonthlyPaymentsAction :: ActionM () -getMonthlyPaymentsAction = +getMonthlyPayments :: ActionM () +getMonthlyPayments = Secure.loggedAction (\user -> do - (liftIO $ runDb (getUserMonthlyPayments (entityKey user))) >>= json + (liftIO $ runDb (P.getUserMonthlyPayments (entityKey user))) >>= json ) -createPaymentAction :: Text -> Int -> Frequency -> ActionM () -createPaymentAction name cost frequency = +createPayment :: Text -> Int -> Frequency -> ActionM () +createPayment name cost frequency = Secure.loggedAction (\user -> do - paymentId <- liftIO . runDb $ createPayment (entityKey user) name cost frequency + paymentId <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency json (JP.PaymentId paymentId) ) -deletePaymentAction :: Text -> ActionM () -deletePaymentAction paymentId = +deletePayment :: Text -> ActionM () +deletePayment paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . runDb $ deleteOwnPayment user (textToKey paymentId) + deleted <- liftIO . runDb $ P.deleteOwnPayment user (textToKey paymentId) if deleted then status ok200 @@ -64,14 +63,14 @@ deletePaymentAction paymentId = jsonObject [("error", Json.String $ getMessage PaymentNotDeleted)] ) -getTotalPaymentsAction :: ActionM () -getTotalPaymentsAction = +getTotalPayments :: ActionM () +getTotalPayments = Secure.loggedAction (\_ -> do - (liftIO . runDb $ getTotalPayments) >>= json + (liftIO . runDb $ P.getTotalPayments) >>= json ) -getPaymentsCountAction :: ActionM () -getPaymentsCountAction = +getPaymentsCount :: ActionM () +getPaymentsCount = Secure.loggedAction (\_ -> do - Number <$> (liftIO . runDb $ getPaymentsCount) >>= json + Number <$> (liftIO . runDb $ P.getPaymentsCount) >>= json ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 4f41c6e..955ad35 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Controller.SignIn - ( signInAction - , validateSignInAction + ( signIn + , validateSignIn ) where import Web.Scotty @@ -38,8 +38,8 @@ import Json (jsonObject) import qualified View.Mail.SignIn as SignIn -signInAction :: Config -> Text -> ActionM () -signInAction config login = +signIn :: Config -> Text -> ActionM () +signIn config login = if isValid (TE.encodeUtf8 login) then do maybeUser <- liftIO . runDb $ getUser login @@ -63,8 +63,8 @@ errorResponse msg = do status badRequest400 jsonObject [("error", Json.String msg)] -validateSignInAction :: Config -> Text -> ActionM () -validateSignInAction config token = do +validateSignIn :: Config -> Text -> ActionM () +validateSignIn config token = do maybeSignIn <- liftIO . runDb $ getSignInToken token now <- liftIO getCurrentTime case maybeSignIn of diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs index 95e5fa8..bc99ea5 100644 --- a/src/server/Controller/User.hs +++ b/src/server/Controller/User.hs @@ -1,25 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + module Controller.User - ( getUsersAction - , whoAmIAction + ( getUsers + , whoAmI + , getIncome ) where import Web.Scotty import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson.Types as Json + import qualified Secure +import Json (jsonObject) + import Model.Database -import Model.User +import qualified Model.User as U -getUsersAction :: ActionM () -getUsersAction = +getUsers :: ActionM () +getUsers = Secure.loggedAction (\_ -> do - (liftIO $ map getJsonUser <$> runDb getUsers) >>= json + (liftIO $ map U.getJsonUser <$> runDb U.getUsers) >>= json ) -whoAmIAction :: ActionM () -whoAmIAction = +whoAmI :: ActionM () +whoAmI = Secure.loggedAction (\user -> do - json (getJsonUser user) + json (U.getJsonUser user) + ) + +getIncome :: ActionM () +getIncome = + Secure.loggedAction (\_ -> do + jsonObject [] ) diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index 7d2b7b6..10e997d 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -26,9 +26,15 @@ radius = px 3 blockPadding :: Size Abs blockPadding = px 15 +blockPercentWidth :: Double +blockPercentWidth = 90 + blockMarginBottom :: Size Abs blockMarginBottom = px 50 +rowHeight :: Size Abs +rowHeight = px 60 + global :: Css global = do @@ -38,24 +44,27 @@ global = do fontFamily ["Cantarell"] [sansSerif] header ? do - let headerHeight = 150 + let headerHeight = 80 + let sidePercent = (pct ((100 - blockPercentWidth) / 2)) h1 ? do fontSize (px 45) - textAlign (alignSide sideCenter) - color C.red + textAlign (alignSide sideLeft) + backgroundColor C.red + color C.white lineHeight (px headerHeight) - + marginBottom blockMarginBottom + paddingLeft sidePercent button # ".signOut" ? do let iconHeight = 50 - let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) + 5 + let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) position absolute top (px sideMargin) - right (pct 2) + right sidePercent height (px iconHeight) lineHeight (px iconHeight) - backgroundColor C.white - color C.red + backgroundColor C.red + color C.white fontSize iconFontSize hover & transform (scale 1.2 1.2) @@ -137,6 +146,11 @@ global = do centeredWithMargin clearFix + ".expand" ? do + position absolute + right blockPadding + bottom (px 2) + ".monthlyPayments" ? do marginBottom blockMarginBottom @@ -144,40 +158,35 @@ global = do float floatLeft width (pct 55) - button # ".count" ? do - width (pct 100) - fontSize (px 18) + ".count" ? do defaultButton C.blue C.white inputHeight - borderRadius radius radius radius radius - textAlign (alignSide sideLeft) - position relative - paddingLeft blockPadding - paddingRight blockPadding - - ".expand" ? do - float floatRight - marginTop (px (-2)) - - ".detail" & - button # ".count" ? - borderRadius radius radius 0 0 - - ".exceedingPayers" ? do - backgroundColor C.green - color C.white - fontSize (px 18) - borderRadius radius radius radius radius + buttonBlock + cursor cursorText + + button # ".count" ? cursor pointer + + ".account" ? do marginBottom blockMarginBottom - paddingLeft blockPadding - paddingRight blockPadding largeScreen $ do float floatRight width (pct 40) - ".exceedingPayer" ? do - lineHeight (px inputHeight) - ".userName" ? marginRight (px 10) + ".exceedingPayers" ? do + defaultButton C.green C.white inputHeight + buttonBlock + + ".exceedingPayer" ? do + lineHeight (px inputHeight) + ".userName" ? marginRight (px 10) + + ".income" ? do + backgroundColor C.lightGrey + lineHeight rowHeight + padding (px 0) (px 20) (px 0) (px 20) + + ".detail" |> (".count" <> ".exceedingPayers") ? + borderRadius radius radius 0 0 ".table" ? do display D.table @@ -187,11 +196,10 @@ global = do ".header" <> ".row" ? display tableRow let headerHeight = (px 70) - let rowHeight = (px 60) ".header" ? do fontWeight bold - backgroundColor C.red + backgroundColor C.blue color C.white fontSize iconFontSize lineHeight headerHeight @@ -261,7 +269,7 @@ global = do form ? do let inputHeight = 50 width (px 500) - marginTop (px 50) + marginTop (px 100) marginLeft auto marginRight auto @@ -296,7 +304,6 @@ defaultButton backgroundCol textCol pxHeight = do borderRadius radius radius radius radius verticalAlign middle cursor pointer - height (px pxHeight) lineHeight (px pxHeight) textAlign (alignSide sideCenter) @@ -311,6 +318,16 @@ defaultInput inputHeight = do centeredWithMargin :: Css centeredWithMargin = do - width (pct 90) + width (pct blockPercentWidth) marginLeft auto marginRight auto + +buttonBlock :: Css +buttonBlock = do + width (pct 100) + fontSize (px 18) + borderRadius radius radius radius radius + textAlign (alignSide sideLeft) + position relative + paddingLeft blockPadding + paddingRight blockPadding diff --git a/src/server/Main.hs b/src/server/Main.hs index 1a151fc..8956fa4 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -33,46 +33,43 @@ main = do middleware $ staticPolicy (noDots >-> addBase "public") - get "/" $ - getIndexAction + get "/" getIndex + post "/signOut" signOut + + -- SignIn post "/signIn" $ do login <- param "login" :: ActionM Text - signInAction config login + signIn config login get "/validateSignIn" $ do token <- param "token" :: ActionM Text - validateSignInAction config token + validateSignIn config token - post "/signOut" $ - signOutAction + -- Users - get "/whoAmI" $ - whoAmIAction + get "/users" getUsers + get "/whoAmI" whoAmI + get "/income" getIncome - get "/users" $ do - getUsersAction + -- Payments get "/payments" $ do - page <- param "page" :: ActionM Int + page <- param "page" :: ActionM Int perPage <- param "perPage" :: ActionM Int - getPaymentsAction page perPage + getPayments page perPage - get "/monthlyPayments" $ do - getMonthlyPaymentsAction + get "/monthlyPayments" getMonthlyPayments post "/payment/add" $ do name <- param "name" :: ActionM Text cost <- param "cost" :: ActionM Int frequency <- param "frequency" :: ActionM Frequency - createPaymentAction name cost frequency + createPayment name cost frequency post "/payment/delete" $ do paymentId <- param "id" :: ActionM Text - deletePaymentAction paymentId - - get "/payments/total" $ do - getTotalPaymentsAction + deletePayment paymentId - get "/payments/count" $ do - getPaymentsCountAction + get "/payments/total" getTotalPayments + get "/payments/count" getPaymentsCount diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs index 20addee..7c1a6ed 100644 --- a/src/server/Model/Mail.hs +++ b/src/server/Model/Mail.hs @@ -10,5 +10,4 @@ data Mail = Mail , to :: [Text] , subject :: Text , plainBody :: LT.Text - , htmlBody :: LT.Text } deriving (Eq, Show) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index 3d915b9..4076768 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -19,8 +19,7 @@ data Key = | SignInExpired | SignInInvalid | SignInMailTitle - | HiMail - | SignInLinkMail + | SignInMail | SignInEmailSent -- Dates @@ -54,7 +53,13 @@ data Key = | MoneySymbol | Punctual | Monthly + | NoMonthlyPayment | SingularMonthlyCount | PluralMonthlyCount + -- Income + + | Income + | NoIncome + deriving (Enum, Bounded, Show) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index 79d177f..fce979a 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -69,25 +69,35 @@ m l SignInMailTitle = English -> T.concat ["Sign in to ", m l SharedCost] French -> T.concat ["Connexion à ", m l SharedCost] -m l HiMail = - case l of - English -> "Hi {1}," - French -> "Salut {1}," - -m l SignInLinkMail = - case l of - English -> - T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l SharedCost - , ":" - ] - French -> - T.concat - [ "Clique sur le lien suivant pour te connecter à " - , 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 @@ -210,20 +220,34 @@ m l Monthly = English -> "Monthly" French -> "Mensuel" +m l NoMonthlyPayment = + case l of + English -> "No monthly payment" + French -> "Aucun paiement mensuel" + m l SingularMonthlyCount = T.concat [ case l of English -> "{1} monthly payment of {2} " French -> "{1} paiement mensuel de {2} " , m l MoneySymbol - , "." ] m l PluralMonthlyCount = T.concat [ case l of - English -> "{1} monthly payments totalling {2} " - French -> "{1} paiements mensuels comptabilisant {2} " - , m l MoneySymbol - , "." + English -> "{1} monthly payments totalling {2}" + French -> "{1} paiements mensuels comptabilisant {2}" ] + +m l Income = + T.concat + [ case l of + English -> "You have a monthly net income of {1}" + French -> "Votre revenu mensuel net est de {1}" + ] + +m l NoIncome = + case l of + English -> "Income not given" + French -> "Revenu non renseigné" diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs index e57f345..8f62bb1 100644 --- a/src/server/SendMail.hs +++ b/src/server/SendMail.hs @@ -24,15 +24,11 @@ sendMail mail = do return result getMimeMail :: Mail -> M.Mail -getMimeMail (Mail from to subject plainBody htmlBody) = +getMimeMail (Mail from to subject plainBody) = let fromMail = M.emptyMail (address from) in fromMail { M.mailTo = map address to - , M.mailParts = - [ [ M.plainPart plainBody - , M.htmlPart htmlBody - ] - ] + , M.mailParts = [ [ M.plainPart plainBody ] ] , M.mailHeaders = [("Subject", subject)] } diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index fc73dae..dca261d 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -8,10 +8,6 @@ import Data.Text (Text) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (toLazyText, fromText) -import Text.Blaze.Html -import Text.Blaze.Html5 -import Text.Blaze.Html.Renderer.Text (renderHtml) - import Model.Database (User(..)) import qualified Model.Mail as M import Model.Message.Key @@ -24,28 +20,10 @@ getMail user url to = , M.to = to , M.subject = (getMessage SignInMailTitle) , M.plainBody = plainBody user url - , M.htmlBody = htmlBody user url } plainBody :: User -> Text -> LT.Text -plainBody user url = - LT.intercalate - "\n" - [ strictToLazy (getParamMessage [userName user] HiMail) - , "" - , strictToLazy (getMessage SignInLinkMail) - , strictToLazy url - ] - -htmlBody :: User -> Text -> LT.Text -htmlBody user url = - renderHtml . docTypeHtml . body $ do - toHtml $ strictToLazy (getParamMessage [userName user] HiMail) - br - br - toHtml $ strictToLazy (getMessage SignInLinkMail) - br - toHtml url +plainBody user url = strictToLazy (getParamMessage [userName user, url] SignInMail) strictToLazy :: Text -> LT.Text strictToLazy = toLazyText . fromText -- cgit v1.2.3