aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Index.hs12
-rw-r--r--src/server/Controller/Payment.hs55
-rw-r--r--src/server/Controller/SignIn.hs12
-rw-r--r--src/server/Controller/User.hs31
-rw-r--r--src/server/Design/Global.hs97
-rw-r--r--src/server/Main.hs39
-rw-r--r--src/server/Model/Mail.hs1
-rw-r--r--src/server/Model/Message/Key.hs9
-rw-r--r--src/server/Model/Message/Translations.hs72
-rw-r--r--src/server/SendMail.hs8
-rw-r--r--src/server/View/Mail/SignIn.hs24
11 files changed, 194 insertions, 166 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 20:55:54 +0000