From d9df5c3fcffe12aac239b58ccf2fd82c19c3be62 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Jan 2016 23:37:14 +0100
Subject: Validate add payment server side

---
 src/client/elm/Model/Action/AddPaymentAction.elm  |  3 ++-
 src/client/elm/Model/Action/LoggedInAction.elm    |  2 +-
 src/client/elm/Model/View/LoggedIn/Account.elm    | 12 ++++++---
 src/client/elm/Model/View/LoggedIn/AddPayment.elm | 16 +-----------
 src/client/elm/Native/Reads.js                    | 22 ----------------
 src/client/elm/Reads.elm                          | 10 --------
 src/client/elm/Server.elm                         | 17 ++++++++++---
 src/client/elm/SimpleHTTP.elm                     |  8 +++++-
 src/client/elm/Update/LoggedIn.elm                | 18 ++++++++++---
 src/client/elm/Update/LoggedIn/AddPayment.elm     | 28 ++++++++++++++++++++
 src/client/elm/Utils/Validation.elm               | 23 -----------------
 src/client/elm/View/LoggedIn/AddPayment.elm       | 10 +++-----
 src/client/elm/View/LoggedIn/Paging.elm           |  4 +--
 src/server/Controller/Payment.hs                  | 18 ++++++++-----
 src/server/Design/LoggedIn/Table.hs               |  1 +
 src/server/Main.hs                                |  2 +-
 src/server/Model/Database.hs                      |  3 +++
 src/server/Model/Json/PaymentId.hs                | 17 -------------
 src/server/Model/Payment.hs                       | 31 ++++++++++++++++++++---
 src/server/Validation.hs                          | 23 +++++++++++++++++
 20 files changed, 146 insertions(+), 122 deletions(-)
 delete mode 100644 src/client/elm/Native/Reads.js
 delete mode 100644 src/client/elm/Reads.elm
 delete mode 100644 src/client/elm/Utils/Validation.elm
 delete mode 100644 src/server/Model/Json/PaymentId.hs
 create mode 100644 src/server/Validation.hs

(limited to 'src')

diff --git a/src/client/elm/Model/Action/AddPaymentAction.elm b/src/client/elm/Model/Action/AddPaymentAction.elm
index a109a49..2d4f92a 100644
--- a/src/client/elm/Model/Action/AddPaymentAction.elm
+++ b/src/client/elm/Model/Action/AddPaymentAction.elm
@@ -3,7 +3,8 @@ module Model.Action.AddPaymentAction
   ) where
 
 type AddPaymentAction =
-  UpdateName String
+  NoOp
+  | UpdateName String
   | UpdateCost String
   | AddError (Maybe String) (Maybe String)
   | ToggleFrequency
diff --git a/src/client/elm/Model/Action/LoggedInAction.elm b/src/client/elm/Model/Action/LoggedInAction.elm
index ef81b09..4538ec7 100644
--- a/src/client/elm/Model/Action/LoggedInAction.elm
+++ b/src/client/elm/Model/Action/LoggedInAction.elm
@@ -11,7 +11,7 @@ type LoggedInAction =
   NoOp
   | UpdateAdd AddPaymentAction
   | UpdatePayments Payments
-  | AddPayment String Int PaymentFrequency
+  | AddPayment String String PaymentFrequency
   | ValidateAddPayment PaymentId String Int PaymentFrequency
   | DeletePayment Payment PaymentFrequency
   | ValidateDeletePayment Payment PaymentFrequency
diff --git a/src/client/elm/Model/View/LoggedIn/Account.elm b/src/client/elm/Model/View/LoggedIn/Account.elm
index 4638c8d..d03d84f 100644
--- a/src/client/elm/Model/View/LoggedIn/Account.elm
+++ b/src/client/elm/Model/View/LoggedIn/Account.elm
@@ -9,8 +9,8 @@ module Model.View.LoggedIn.Account
 
 import Result as Result exposing (Result(..))
 import Dict
+import String
 
-import Utils.Validation exposing (..)
 import Utils.Dict exposing (mapValues)
 
 import Model.Translations exposing (..)
@@ -62,6 +62,10 @@ initIncomeEdition income =
 
 validateIncome : String -> Translations -> Result String Int
 validateIncome amount translations =
-  amount
-    |> validateNonEmpty (getMessage "IncomeRequired" translations)
-    |> flip Result.andThen (validateNumber (getMessage "IncomeMustBePositiveNumber" translations) (\number -> number > 0))
+  case String.toInt amount of
+    Ok number ->
+      if number > 0
+        then Ok number
+        else Err <| getMessage "IncomeMustBePositiveNumber" translations
+    Err _ ->
+      Err <| getMessage "IncomeRequired" translations
diff --git a/src/client/elm/Model/View/LoggedIn/AddPayment.elm b/src/client/elm/Model/View/LoggedIn/AddPayment.elm
index 3a14b00..c7680bb 100644
--- a/src/client/elm/Model/View/LoggedIn/AddPayment.elm
+++ b/src/client/elm/Model/View/LoggedIn/AddPayment.elm
@@ -1,13 +1,10 @@
 module Model.View.LoggedIn.AddPayment
   ( AddPayment
   , initAddPayment
-  , validateName
-  , validateCost
   ) where
 
 import Result as Result exposing (Result(..))
-
-import Utils.Validation exposing (..)
+import Json.Decode exposing ((:=))
 
 import Model.Translations exposing (..)
 import Model.Payment exposing (PaymentFrequency(..))
@@ -30,14 +27,3 @@ initAddPayment frequency =
   , frequency = frequency
   , waitingServer = False
   }
-
-validateName : String -> Translations -> Result String String
-validateName name translations =
-  name
-    |> validateNonEmpty (getMessage "CategoryRequired" translations)
-
-validateCost : String -> Translations -> Result String Int
-validateCost cost translations =
-  cost
-    |> validateNonEmpty (getMessage "CostRequired" translations)
-    |> flip Result.andThen (validateNumber (getMessage "CostRequired" translations) ((/=) 0))
diff --git a/src/client/elm/Native/Reads.js b/src/client/elm/Native/Reads.js
deleted file mode 100644
index 5785aed..0000000
--- a/src/client/elm/Native/Reads.js
+++ /dev/null
@@ -1,22 +0,0 @@
-Elm.Native.Reads = {};
-Elm.Native.Reads.make = function(localRuntime) {
-
-  localRuntime.Native = localRuntime.Native || {};
-  localRuntime.Native.Reads = localRuntime.Native.Reads || {};
-  if(localRuntime.Native.Reads.values) {
-    return localRuntime.Native.Reads.values;
-  }
-
-  var Maybe = Elm.Maybe.make(localRuntime);
-
-  function readInt(str) {
-    var number = Number(str);
-    return isNaN(number) || str === ''
-             ? Maybe.Nothing
-             : Maybe.Just(number);
-  }
-
-  return localRuntime.Native.Reads.values = {
-    readInt: readInt
-  };
-};
diff --git a/src/client/elm/Reads.elm b/src/client/elm/Reads.elm
deleted file mode 100644
index f855802..0000000
--- a/src/client/elm/Reads.elm
+++ /dev/null
@@ -1,10 +0,0 @@
-module Reads
-  ( readInt
-  ) where
-
-
-import Native.Reads
-import Result exposing (Result)
-
-readInt : String -> Maybe Int
-readInt = Native.Reads.readInt
diff --git a/src/client/elm/Server.elm b/src/client/elm/Server.elm
index 3a6c86a..e50de7e 100644
--- a/src/client/elm/Server.elm
+++ b/src/client/elm/Server.elm
@@ -14,16 +14,19 @@ import Json.Decode as Json exposing ((:=))
 import Date
 import Time exposing (Time)
 import Debug
+import String
 
 import SimpleHTTP exposing (..)
 
 import Model.Action as U exposing (Action)
+import Model.Action.AddPaymentAction as AddPayment
 import Model.Action.LoggedInAction as UL exposing (LoggedInAction)
 import Model.Action.MonthlyAction as UM exposing (MonthlyAction)
 import Model.Action.AccountAction as UA exposing (AccountAction)
 import Model.Payment exposing (..)
 import Model.Payer exposing (Payers, payersDecoder)
 import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
+import Model.Translations exposing (Translations, getMessage)
 
 import Update.SignIn exposing (updateSignIn)
 
@@ -32,11 +35,17 @@ signIn assertion =
   post ("/signIn?assertion=" ++ assertion)
     |> flip Task.andThen (always initViewAction)
 
-addPayment : String -> Int -> PaymentFrequency -> Task Http.Error LoggedInAction
-addPayment name cost frequency =
-  post ("/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost) ++ "&frequency=" ++ (toString frequency))
+addPayment : Translations -> String -> String -> PaymentFrequency -> Task Http.Error LoggedInAction
+addPayment translations name cost frequency =
+  post ("/payment/add?name=" ++ name ++ "&cost=" ++ cost ++ "&frequency=" ++ (toString frequency))
     |> flip Task.andThen (decodeHttpValue <| "id" := paymentIdDecoder)
-    |> Task.map (\paymentId -> (UL.ValidateAddPayment paymentId name cost frequency))
+    |> Task.map (\paymentId ->
+         case String.toInt cost of
+           Err _ ->
+             UL.UpdateAdd (AddPayment.AddError Nothing (Just (getMessage "CostRequired" translations)))
+           Ok costNumber ->
+             UL.ValidateAddPayment paymentId name costNumber frequency
+       )
 
 deletePayment : Payment -> PaymentFrequency -> Task Http.Error LoggedInAction
 deletePayment payment frequency =
diff --git a/src/client/elm/SimpleHTTP.elm b/src/client/elm/SimpleHTTP.elm
index 99a7056..3e01178 100644
--- a/src/client/elm/SimpleHTTP.elm
+++ b/src/client/elm/SimpleHTTP.elm
@@ -22,7 +22,13 @@ handleResponse : Response -> Task Error Value
 handleResponse response =
   if 200 <= response.status && response.status < 300
     then Task.succeed response.value
-    else fail (BadResponse response.status response.statusText)
+    else fail (BadResponse response.status (responseString response.value))
+
+responseString : Value -> String
+responseString value =
+  case value of
+    Text str -> str
+    _ -> ""
 
 promoteError : RawError -> Error
 promoteError rawError =
diff --git a/src/client/elm/Update/LoggedIn.elm b/src/client/elm/Update/LoggedIn.elm
index 74e213a..134aec2 100644
--- a/src/client/elm/Update/LoggedIn.elm
+++ b/src/client/elm/Update/LoggedIn.elm
@@ -4,9 +4,11 @@ module Update.LoggedIn
 
 import Date
 import Dict
+import Debug
+import Task
 
 import Effects exposing (Effects)
-import Task
+import Http exposing (Error(..))
 
 import Server
 
@@ -20,7 +22,7 @@ import Model.Action.AddPaymentAction as AddPayment
 import Model.View.LoggedInView exposing (..)
 import Model.View.LoggedIn.AddPayment exposing (..)
 
-import Update.LoggedIn.AddPayment exposing (updateAddPayment)
+import Update.LoggedIn.AddPayment exposing (updateAddPayment, addPaymentError)
 import Update.LoggedIn.Monthly exposing (updateMonthly)
 import Update.LoggedIn.Account exposing (updateAccount)
 
@@ -42,8 +44,16 @@ updateLoggedIn model action loggedInView =
 
     AddPayment name cost frequency ->
       ( { loggedInView | add = updateAddPayment AddPayment.WaitingServer loggedInView.add }
-      , Server.addPayment name cost frequency
-          |> flip Task.onError (always <| Task.succeed NoOp)
+      , Server.addPayment model.translations name cost frequency
+          |> flip Task.onError (\err ->
+              case err of
+                BadResponse 400 jsonErr ->
+                  case addPaymentError model.translations jsonErr of
+                    Just addPaymentAction -> Task.succeed (UpdateAdd addPaymentAction)
+                    Nothing -> Task.succeed NoOp
+                _ ->
+                  Task.succeed NoOp
+             )
           |> Effects.task
       )
 
diff --git a/src/client/elm/Update/LoggedIn/AddPayment.elm b/src/client/elm/Update/LoggedIn/AddPayment.elm
index 3eb2ea4..4c9c484 100644
--- a/src/client/elm/Update/LoggedIn/AddPayment.elm
+++ b/src/client/elm/Update/LoggedIn/AddPayment.elm
@@ -1,26 +1,54 @@
 module Update.LoggedIn.AddPayment
   ( updateAddPayment
+  , addPaymentError
   ) where
 
+import Maybe
+import Json.Decode as Json exposing ((:=))
+
 import Model.Action.AddPaymentAction exposing (..)
 import Model.View.LoggedIn.AddPayment exposing (..)
+import Model.Translations exposing (Translations, getMessage)
 import Model.Payment exposing (PaymentFrequency(..))
 
 updateAddPayment : AddPaymentAction -> AddPayment -> AddPayment
 updateAddPayment action addPayment =
   case action of
+
+    NoOp ->
+      addPayment
+
     UpdateName name ->
       { addPayment | name = name }
+
     UpdateCost cost ->
       { addPayment | cost = cost }
+
     AddError nameError costError ->
       { addPayment
       | nameError = nameError
       , costError = costError
+      , waitingServer = False
       }
+
     ToggleFrequency ->
       { addPayment
       | frequency = if addPayment.frequency == Punctual then Monthly else Punctual
       }
+
     WaitingServer ->
       { addPayment | waitingServer = True }
+
+addPaymentError : Translations -> String -> Maybe AddPaymentAction
+addPaymentError translations jsonErr =
+  let decoder =
+        Json.object2 (,)
+          (Json.maybe <| "name" := Json.string)
+          (Json.maybe <| "cost" := Json.string)
+  in  case Json.decodeString decoder jsonErr of
+        Err _ ->
+          Nothing
+        Ok (mbNameKey, mbCostKey) ->
+          Just <| AddError
+            (Maybe.map (flip getMessage translations) mbNameKey)
+            (Maybe.map (flip getMessage translations) mbCostKey)
diff --git a/src/client/elm/Utils/Validation.elm b/src/client/elm/Utils/Validation.elm
deleted file mode 100644
index b9bccb3..0000000
--- a/src/client/elm/Utils/Validation.elm
+++ /dev/null
@@ -1,23 +0,0 @@
-module Utils.Validation
-  ( validateNonEmpty
-  , validateNumber
-  ) where
-
-import String
-import Reads exposing (readInt)
-
-validateNonEmpty : String -> String -> Result String String
-validateNonEmpty message str =
-  if String.isEmpty str
-   then Err message
-   else Ok str
-
-validateNumber : String -> (Int -> Bool) -> String -> Result String Int
-validateNumber message numberForm str =
-  case readInt str of
-    Just number ->
-      if numberForm number
-        then Ok number
-        else Err message
-    Nothing ->
-      Err message
diff --git a/src/client/elm/View/LoggedIn/AddPayment.elm b/src/client/elm/View/LoggedIn/AddPayment.elm
index 0b39591..0149432 100644
--- a/src/client/elm/View/LoggedIn/AddPayment.elm
+++ b/src/client/elm/View/LoggedIn/AddPayment.elm
@@ -2,7 +2,6 @@ module View.LoggedIn.AddPayment
   ( addPayment
   ) where
 
-import Reads exposing (readInt)
 import Result exposing (..)
 import Signal exposing (Address)
 
@@ -31,13 +30,10 @@ addPayment address model loggedInView =
   H.form
     [ let update =
             if loggedInView.add.waitingServer
-              then Action.NoOp
+              then
+                Action.NoOp
               else
-                case (validateName loggedInView.add.name model.translations, validateCost loggedInView.add.cost model.translations) of
-                  (Ok name, Ok cost) ->
-                    UpdateLoggedIn <| LoggedInAction.AddPayment name cost loggedInView.add.frequency
-                  (resName, resCost) ->
-                    UpdateLoggedIn <| UpdateAdd <| AddError (toMaybeError resName) (toMaybeError resCost)
+                UpdateLoggedIn <| LoggedInAction.AddPayment loggedInView.add.name loggedInView.add.cost loggedInView.add.frequency
       in  onSubmitPrevDefault address update
     , class "addPayment"
     ]
diff --git a/src/client/elm/View/LoggedIn/Paging.elm b/src/client/elm/View/LoggedIn/Paging.elm
index 154686a..b722ee7 100644
--- a/src/client/elm/View/LoggedIn/Paging.elm
+++ b/src/client/elm/View/LoggedIn/Paging.elm
@@ -8,7 +8,7 @@ import Html exposing (..)
 import Html.Attributes exposing (..)
 import Html.Events exposing (..)
 
-import Model.Action exposing (..)
+import Model.Action as Action exposing (..)
 import Model.Action.LoggedInAction exposing (..)
 import Model.View.LoggedInView exposing (..)
 import Model.Payment exposing (perPage)
@@ -94,6 +94,6 @@ paymentsPage address loggedInView page =
             , ("current", onCurrentPage)
             ]
         , onClick address <|
-            if onCurrentPage then NoOp else UpdateLoggedIn (UpdatePage page)
+            if onCurrentPage then Action.NoOp else UpdateLoggedIn (UpdatePage page)
         ]
         [ text (toString page) ]
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index d2a9258..e94b300 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -10,23 +10,24 @@ module Controller.Payment
 
 import Web.Scotty
 
-import Network.HTTP.Types.Status (ok200)
+import Network.HTTP.Types.Status (ok200, badRequest400)
 
 import Database.Persist
 
 import Control.Monad.IO.Class (liftIO)
 
 import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Aeson.Types as Json
 
 import qualified Secure
 
-import Json (jsonError)
+import Json (jsonObject, jsonError)
 
 import Model.Database
 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))
 
@@ -42,11 +43,16 @@ getMonthlyPayments =
     (liftIO $ runDb (P.getUserMonthlyPayments (entityKey user))) >>= json
   )
 
-createPayment :: Text -> Int -> Frequency -> ActionM ()
+createPayment :: Text -> Text -> Frequency -> ActionM ()
 createPayment name cost frequency =
   Secure.loggedAction (\user -> do
-    paymentId <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency
-    json (JP.PaymentId paymentId)
+    creationResult <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency
+    case creationResult of
+      Left errors -> do
+        status badRequest400
+        jsonObject . map (\(a, b) -> (a, Json.String . T.pack . show $ b)) $ errors
+      Right paymentId ->
+        jsonObject [("id", Json.Number . fromIntegral . keyToInt64 $ paymentId)]
   )
 
 deletePayment :: Text -> ActionM ()
diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs
index d9fc318..e5ed4bf 100644
--- a/src/server/Design/LoggedIn/Table.hs
+++ b/src/server/Design/LoggedIn/Table.hs
@@ -91,6 +91,7 @@ tableDesign =
         textAlign (alignSide sideCenter)
         button ? do
           defaultButton C.red C.white (px rowHeightPx) focusLighten
+          borderRadius (px 0) (px 0) (px 0) (px 0)
           position absolute
           top (px 0)
           right (px 0)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 9f21873..e5d8cca 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -61,7 +61,7 @@ main = do
 
         post "/payment/add" $ do
           name <- param "name" :: ActionM Text
-          cost <- param "cost" :: ActionM Int
+          cost <- param "cost" :: ActionM Text
           frequency <- param "frequency" :: ActionM Frequency
           createPayment name cost frequency
 
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 67cc8b3..a98e69a 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -69,3 +69,6 @@ runMigrations = runDb $ runMigration migrateAll
 
 textToKey :: (ToBackendKey SqlBackend a) => Text -> Key a
 textToKey text = toSqlKey (read (unpack text) :: Int64)
+
+keyToInt64 :: (ToBackendKey SqlBackend a) => Key a -> Int64
+keyToInt64 = fromSqlKey
diff --git a/src/server/Model/Json/PaymentId.hs b/src/server/Model/Json/PaymentId.hs
deleted file mode 100644
index 3cbeb3c..0000000
--- a/src/server/Model/Json/PaymentId.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.PaymentId
-  ( PaymentId(..)
-  ) where
-
-import Data.Aeson
-import GHC.Generics
-
-import qualified Model.Database as D
-
-data PaymentId = PaymentId
-  { id :: D.PaymentId
-  } deriving (Show, Generic)
-
-instance FromJSON PaymentId
-instance ToJSON PaymentId
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index de4a759..404b143 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Model.Payment
   ( getPunctualPayments
   , getUserMonthlyPayments
@@ -8,16 +10,21 @@ module Model.Payment
   ) where
 
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
+import Data.Either (lefts)
 
 import Control.Monad.IO.Class (liftIO)
 
 import Database.Persist
 import qualified Database.Persist as P
 
+import qualified Validation
+
 import Model.Database
 import Model.Frequency
 import qualified Model.Json.Payment as P
+import qualified Model.Message.Key as K
 
 getPunctualPayments :: Persist [P.Payment]
 getPunctualPayments =
@@ -50,10 +57,26 @@ getJsonPayment paymentEntity =
         , P.userId = paymentUserId payment
         }
 
-createPayment :: UserId -> Text -> Int -> Frequency -> Persist PaymentId
-createPayment userId name cost frequency = do
-  now <- liftIO getCurrentTime
-  insert $ Payment userId now name cost Nothing frequency
+createPayment :: UserId -> Text -> Text -> Frequency -> Persist (Either [(Text, K.Key)] PaymentId)
+createPayment userId name cost frequency =
+  case validatePayment name cost of
+    Left err ->
+      return . Left $ err
+    Right (validatedName, validatedCost) -> do
+      now <- liftIO getCurrentTime
+      Right <$> insert (Payment userId now validatedName validatedCost Nothing frequency)
+
+validatePayment :: Text -> Text -> Either [(Text, K.Key)] (Text, Int)
+validatePayment name cost =
+  let eitherName = Validation.nonEmpty K.CategoryRequired name
+      eitherCost = Validation.nonEmpty K.CostRequired cost >>= Validation.number K.CostRequired (/= 0)
+  in  case (eitherName, eitherCost) of
+        (Right validatedName, Right validatedCost) ->
+          Right (validatedName, validatedCost)
+        _ ->
+          let nameErrors = map (\x -> ("name", x)) $ lefts [eitherName]
+              costErrors = map (\x -> ("cost", x)) $ lefts [eitherCost]
+          in  Left (nameErrors ++ costErrors)
 
 deleteOwnPayment :: Entity User -> PaymentId -> Persist Bool
 deleteOwnPayment user paymentId = do
diff --git a/src/server/Validation.hs b/src/server/Validation.hs
new file mode 100644
index 0000000..9035be7
--- /dev/null
+++ b/src/server/Validation.hs
@@ -0,0 +1,23 @@
+module Validation
+  ( nonEmpty
+  , number
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+nonEmpty :: a -> Text -> Either a Text
+nonEmpty x str =
+  if T.null str
+   then Left x
+   else Right str
+
+number :: x -> (Int -> Bool) -> Text -> Either x Int
+number x numberForm str =
+  case reads (T.unpack str) :: [(Int, String)] of
+    (number, _) : _ ->
+      if numberForm number
+        then Right number
+        else Left x
+    _ ->
+      Left x
-- 
cgit v1.2.3