From 6a0c5087f716ed6c876a666db6573491bfd3e094 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 12 Jun 2016 23:54:17 +0200
Subject: Design income form

---
 src/server/Controller/Income.hs          |  8 ++---
 src/server/Design/Color.hs               |  3 ++
 src/server/Design/Form.hs                | 62 ++++++++++++++++++++++++++++++++
 src/server/Design/Global.hs              |  2 ++
 src/server/Design/Helper.hs              |  1 +
 src/server/Design/LoggedIn/Home/Add.hs   |  3 +-
 src/server/Design/LoggedIn/Income.hs     | 18 +++++++++-
 src/server/Main.hs                       |  6 +---
 src/server/Model/Database.hs             |  4 ++-
 src/server/Model/Income.hs               | 12 ++++---
 src/server/Model/Json/AddIncome.hs       | 17 +++++++++
 src/server/Model/Json/Income.hs          |  5 ++-
 src/server/Model/Message/Key.hs          | 12 +++++--
 src/server/Model/Message/Translations.hs | 47 ++++++++++++++++++------
 14 files changed, 168 insertions(+), 32 deletions(-)
 create mode 100644 src/server/Design/Form.hs
 create mode 100644 src/server/Model/Json/AddIncome.hs

(limited to 'src/server')

diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs
index 4474d51..70e40ce 100644
--- a/src/server/Controller/Income.hs
+++ b/src/server/Controller/Income.hs
@@ -16,7 +16,6 @@ import Database.Persist
 
 import Data.Text (Text)
 import qualified Data.Text.Lazy as TL
-import Data.Time.Clock (UTCTime)
 
 import qualified Secure
 
@@ -25,6 +24,7 @@ import Json (jsonId)
 import Model.Database
 import qualified Model.Income as Income
 import qualified Model.Message.Key as Key
+import qualified Model.Json.AddIncome as Json
 
 getIncomes :: ActionM ()
 getIncomes =
@@ -32,10 +32,10 @@ getIncomes =
     (liftIO $ map Income.getJsonIncome <$> runDb Income.getIncomes) >>= json
   )
 
-addIncome :: UTCTime -> Int -> ActionM ()
-addIncome creation amount =
+addIncome :: Json.AddIncome -> ActionM ()
+addIncome (Json.AddIncome date amount) =
   Secure.loggedAction (\user ->
-    (liftIO . runDb $ Income.addIncome (entityKey user) creation amount) >>= jsonId
+    (liftIO . runDb $ Income.addIncome (entityKey user) date amount) >>= jsonId
   )
 
 deleteOwnIncome :: Text -> ActionM ()
diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs
index 7520e4e..afc601f 100644
--- a/src/server/Design/Color.hs
+++ b/src/server/Design/Color.hs
@@ -10,6 +10,9 @@ white = C.white
 chestnutRose :: C.Color
 chestnutRose = C.rgb 207 92 86
 
+unknown :: C.Color
+unknown = C.rgb 86 92 207
+
 mossGreen :: C.Color
 mossGreen = C.rgb 159 210 165
 
diff --git a/src/server/Design/Form.hs b/src/server/Design/Form.hs
new file mode 100644
index 0000000..bb7d7db
--- /dev/null
+++ b/src/server/Design/Form.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Design.Form
+  ( design
+  ) where
+
+import Data.Monoid ((<>))
+
+import Clay
+
+-- import Design.Constants
+import Design.Color as Color
+-- import qualified Design.Media as Media
+
+
+design :: Css
+design = do
+
+  let inputHeight = 30
+  let inputTop = 22
+  let inputPaddingBottom = 3
+
+  ".textInput" ? do
+    position relative
+    marginBottom (em 1)
+    paddingTop (px inputTop)
+    marginTop (px (-10))
+
+    input ? do
+      position relative
+      zIndex 1
+      backgroundColor transparent
+      paddingBottom (px inputPaddingBottom)
+      borderStyle none
+      borderBottom solid (px 1) Color.dustyGray
+      marginBottom (px 5)
+      height (px inputHeight)
+      lineHeight (px inputHeight)
+      focus & do
+        borderWidth (px 2)
+        paddingBottom (px $ inputPaddingBottom - 1)
+
+    label ? do
+      lineHeight (px inputHeight)
+      position absolute
+      top (px inputTop)
+      left (px 0)
+      color Color.silver
+      transition "all" (sec 0.2) easeIn (sec 0)
+
+    (input # ".filled" |+ label) <> (input # focus |+ label) ? do
+      top (px 0)
+      fontSize (pct 80)
+
+    ".error" & do
+      input ? do
+        borderBottomColor Color.chestnutRose
+
+      ".errorMessage" ? do
+        position absolute
+        color Color.chestnutRose
+        fontSize (pct 80)
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 900994a..864add0 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -11,6 +11,7 @@ import Data.Text.Lazy (Text)
 import qualified Design.Header as HeaderDesign
 import qualified Design.SignIn as SignInDesign
 import qualified Design.LoggedIn as LoggedInDesign
+import qualified Design.Form as Form
 
 import Design.Animation.Keyframes
 
@@ -25,6 +26,7 @@ global = do
   header ? HeaderDesign.design
   ".signIn" ? SignInDesign.design
   ".loggedIn" ? LoggedInDesign.design
+  form ? Form.design
 
   allKeyframes
 
diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs
index 766fbdb..deb0aab 100644
--- a/src/server/Design/Helper.hs
+++ b/src/server/Design/Helper.hs
@@ -30,6 +30,7 @@ clearFix =
 defaultButton :: Color -> Color -> Size a -> (Color -> Color) -> Css
 defaultButton backgroundCol textCol h focusOp = do
   backgroundColor backgroundCol
+  padding (px 0) (px 10) (px 0) (px 10)
   color textCol
   borderRadius radius radius radius radius
   verticalAlign middle
diff --git a/src/server/Design/LoggedIn/Home/Add.hs b/src/server/Design/LoggedIn/Home/Add.hs
index f4e001f..6856af9 100644
--- a/src/server/Design/LoggedIn/Home/Add.hs
+++ b/src/server/Design/LoggedIn/Home/Add.hs
@@ -40,7 +40,8 @@ design = do
       defaultInput inputHeight
       borderRadius radius (px 0) (px 0) radius
       "width" -: "calc(100% - 40px)"
-    "input:focus + label" ? backgroundColor Color.silver
+    input # focus |+ label ?
+      backgroundColor Color.silver
     hover & do
       input ? borderColor Color.silver
       label ? backgroundColor Color.silver
diff --git a/src/server/Design/LoggedIn/Income.hs b/src/server/Design/LoggedIn/Income.hs
index 99626ba..bebd136 100644
--- a/src/server/Design/LoggedIn/Income.hs
+++ b/src/server/Design/LoggedIn/Income.hs
@@ -6,8 +6,24 @@ module Design.LoggedIn.Income
 
 import Clay
 
+import qualified Design.Helper as Helper
+import qualified Design.Constants as Constants
+import qualified Design.Color as Color
+
 design :: Css
 design = do
+
   h1 ? paddingBottom (px 0)
+
   form ? do
-    "margin-bottom" -: "3vh"
+    display flex
+    "alignItems" -: "center"
+    "margin-bottom" -: "4vh"
+    ".textInput" ? marginRight (px 30)
+
+    button ? do
+      Helper.defaultButton Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+      marginTop (px 3)
+
+  ul # ".incomes" ? button ?
+    marginLeft (px 12)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 5524ba7..9946961 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -11,7 +11,6 @@ import MonthlyPaymentJob (monthlyPaymentJobListener)
 
 import Data.Text (Text)
 import qualified Data.Text.IO as T
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 
 import Controller.Index
 import Controller.SignIn
@@ -63,10 +62,7 @@ main = do
 
         get "/incomes" getIncomes
 
-        post "/income" $ do
-          creation <- param "creation" :: ActionM Int
-          amount <- param "amount" :: ActionM Int
-          addIncome (posixSecondsToUTCTime $ (fromIntegral creation) / 1000) amount
+        post "/income" $ jsonData >>= addIncome
 
         delete "/income" $ do
           incomeId <- param "id" :: ActionM Text
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 0915afe..5df925a 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -16,6 +16,7 @@ import Control.Monad.Trans.Resource (runResourceT, ResourceT)
 
 import Data.Text
 import Data.Time.Clock (UTCTime)
+import Data.Time.Calendar (Day)
 import Data.Int (Int64)
 
 import Database.Persist.Sqlite
@@ -55,8 +56,9 @@ Job
   deriving Show
 Income
   userId UserId
-  creation UTCTime
+  date Day
   amount Int
+  createdAt UTCTime
   deletedAt UTCTime Maybe
   deriving Show
 |]
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
index c0cac45..119a44f 100644
--- a/src/server/Model/Income.hs
+++ b/src/server/Model/Income.hs
@@ -5,7 +5,8 @@ module Model.Income
   , deleteOwnIncome
   ) where
 
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Calendar (Day)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -16,15 +17,16 @@ import qualified Model.Json.Income as Json
 
 getJsonIncome :: Entity Income -> Json.Income
 getJsonIncome incomeEntity =
-  Json.Income (entityKey incomeEntity) (incomeUserId income) (incomeCreation income) (incomeAmount income)
+  Json.Income (entityKey incomeEntity) (incomeUserId income) (incomeDate income) (incomeAmount income)
   where income = entityVal incomeEntity
 
 getIncomes :: Persist [Entity Income]
 getIncomes = selectList [IncomeDeletedAt ==. Nothing] []
 
-addIncome :: UserId -> UTCTime -> Int -> Persist IncomeId
-addIncome userId creation amount = do
-  insert (Income userId creation amount Nothing)
+addIncome :: UserId -> Day -> Int -> Persist IncomeId
+addIncome userId day amount = do
+  now <- liftIO getCurrentTime
+  insert (Income userId day amount now Nothing)
 
 deleteOwnIncome :: Entity User -> IncomeId -> Persist Bool
 deleteOwnIncome user incomeId = do
diff --git a/src/server/Model/Json/AddIncome.hs b/src/server/Model/Json/AddIncome.hs
new file mode 100644
index 0000000..6570ba9
--- /dev/null
+++ b/src/server/Model/Json/AddIncome.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.AddIncome
+  ( AddIncome(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Time.Calendar (Day)
+
+data AddIncome = AddIncome
+  { day :: Day
+  , amount :: Int
+  } deriving (Show, Generic)
+
+instance FromJSON AddIncome
diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs
index 6ad331a..e80ab63 100644
--- a/src/server/Model/Json/Income.hs
+++ b/src/server/Model/Json/Income.hs
@@ -7,16 +7,15 @@ module Model.Json.Income
 import GHC.Generics
 
 import Data.Aeson
-import Data.Time.Clock (UTCTime)
+import Data.Time.Calendar (Day)
 
 import Model.Database (IncomeId, UserId)
 
 data Income = Income
   { id :: IncomeId
   , userId :: UserId
-  , creation :: UTCTime
+  , day :: Day
   , amount :: Int
   } deriving (Show, Generic)
 
-instance FromJSON Income
 instance ToJSON Income
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 4a49900..d34eea3 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -51,7 +51,6 @@ data Key =
 
   | CategoryRequired
   | CostRequired
-  | DateValidationError
 
   -- Payments
 
@@ -77,12 +76,21 @@ data Key =
   -- Income
 
   | CumulativeIncomesSince
-  | AddIncome
   | Income
   | MonthlyNetIncomes
   | IncomeNotDeleted
   | Creation
   | Amount
+  | Delete
+
+  -- Form
+
+  | Empty
+  | InvalidString
+  | InvalidDate
+  | InvalidInt
+  | SmallerIntThan
+  | GreaterIntThan
 
   -- Http error
 
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index 3ceb7a3..2060611 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -198,11 +198,6 @@ m l CostRequired =
     English -> "Type a positive cost."
     French  -> "Entre un coût positif."
 
-m l DateValidationError =
-  case l of
-    English -> "The date must be day/month/year"
-    French  -> "La date doit avoir la forme jour/mois/année"
-
 -- Payments
 
 m l Add =
@@ -289,11 +284,6 @@ m l CumulativeIncomesSince =
     English -> "Cumulative incomes since {0}"
     French  -> "Revenus nets cumulés depuis le {0}"
 
-m l AddIncome =
-  case l of
-    English -> "Add a monthly income"
-    French  -> "Ajouter un revenu mensuel net"
-
 m l Income =
   case l of
     English -> "Income"
@@ -319,6 +309,43 @@ m l Amount =
     English -> "Amount"
     French  -> "Montant"
 
+m l Delete =
+  case l of
+    English -> "Delete"
+    French  -> "Supprimer"
+
+-- 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 InvalidInt =
+  case l of
+    English -> "Integer required"
+    French  -> "Entier requis"
+
+m l SmallerIntThan =
+  case l of
+    English -> "Integer bigger than {0} required"
+    French  -> "Entier supérieur à {0} requis"
+
+m l GreaterIntThan =
+  case l of
+    English -> "Integer smaller than {0} required"
+    French  -> "Entier inférieur à {0} requis"
+
 -- Http error
 
 m l Timeout =
-- 
cgit v1.2.3