Adding UI income read-only

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