From 2a53fe50c62d4b7aec0f422998c743f68aa523c1 Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Tue, 21 Jul 2015 23:25:58 +0200
Subject: Adding the payment without reloading the page

---
 src/client/Main.elm                   | 35 ++++++++------
 src/client/Model.elm                  |  8 +++-
 src/client/Model/Message.elm          |  8 ++++
 src/client/Model/View/PaymentView.elm | 10 ++--
 src/client/Native/Reads.js            | 27 +++++++++++
 src/client/Reads.elm                  | 10 ++++
 src/client/ServerCommunication.elm    | 17 ++++---
 src/client/Update.elm                 | 13 ++++--
 src/client/Update/Payment.elm         | 20 +++++++-
 src/client/View/Events.elm            | 19 ++++++++
 src/client/View/Payments/Add.elm      | 20 +++++---
 src/client/View/SignIn.elm            | 17 +++----
 src/server/Application.hs             | 86 +++++++++++++++++++----------------
 src/server/Design/Global.hs           |  2 +-
 src/server/Main.hs                    |  3 ++
 src/server/Secure.hs                  | 23 ++++++++--
 16 files changed, 224 insertions(+), 94 deletions(-)
 create mode 100644 src/client/Model/Message.elm
 create mode 100644 src/client/Native/Reads.js
 create mode 100644 src/client/Reads.elm
 create mode 100644 src/client/View/Events.elm

(limited to 'src')

diff --git a/src/client/Main.elm b/src/client/Main.elm
index 678d20e..fd0cec7 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -10,9 +10,11 @@ import Html exposing (Html)
 
 import Http
 import Task exposing (..)
+import Time exposing (..)
 
 import Model exposing (Model, initialModel)
 import Model.Payment exposing (Payments, paymentsDecoder)
+import Model.Message exposing (messageDecoder)
 
 import Update exposing (Action(..), actions, updateModel)
 import Update.SignIn exposing (..)
@@ -27,34 +29,41 @@ main : Signal Html
 main = Signal.map renderPage model
 
 model : Signal Model
-model = Signal.foldp updateModel initialModel actions.signal
+model = Signal.foldp updateModel (initialModel initialTime) update
 
--------------------------
+update : Signal Action
+update = Signal.mergeMany
+  [ Signal.map UpdateTime (Time.every 30)
+  , actions.signal
+  ]
+
+---------------------------------------
 
 port signInError : Maybe String
 
 ---------------------------------------
 
-port fetchPayments : Task Http.Error ()
-port fetchPayments =
+port initialTime : Time
+
+---------------------------------------
+
+port initView : Task Http.Error ()
+port initView =
   case signInError of
     Just msg ->
       Signal.send actions.address (SignInError msg)
     Nothing ->
-      getPayments
-        |> flip Task.andThen reportSuccess
-        |> flip Task.onError reportError
-
-reportSuccess : Payments -> Task x ()
-reportSuccess payments = Signal.send actions.address (GoPaymentView payments)
+      Task.map2 GoPaymentView getUserName getPayments
+        |> flip Task.andThen (Signal.send actions.address)
+        |> flip Task.onError (\_ -> Signal.send actions.address GoSignInView)
 
-reportError : Http.Error -> Task x ()
-reportError error = Signal.send actions.address GoSignInView
+getUserName : Task Http.Error String
+getUserName = Http.get messageDecoder "/userName"
 
 getPayments : Task Http.Error Payments
 getPayments = Http.get paymentsDecoder "/payments"
 
----------------------------------------------------
+---------------------------------------
 
 port serverCommunicationsPort : Signal (Task Http.RawError ())
 port serverCommunicationsPort =
diff --git a/src/client/Model.elm b/src/client/Model.elm
index 8005429..45fdf87 100644
--- a/src/client/Model.elm
+++ b/src/client/Model.elm
@@ -3,13 +3,17 @@ module Model
   , initialModel
   ) where
 
+import Time exposing (Time)
+
 import Model.View exposing (..)
 
 type alias Model =
   { view : View
+  , currentTime : Time
   }
 
-initialModel : Model
-initialModel =
+initialModel : Time -> Model
+initialModel initialTime =
   { view = LoadingView
+  , currentTime = initialTime
   }
diff --git a/src/client/Model/Message.elm b/src/client/Model/Message.elm
new file mode 100644
index 0000000..9f21fd3
--- /dev/null
+++ b/src/client/Model/Message.elm
@@ -0,0 +1,8 @@
+module Model.Message
+  ( messageDecoder
+  ) where
+
+import Json.Decode exposing (..)
+
+messageDecoder : Decoder String
+messageDecoder = ("message" := string)
diff --git a/src/client/Model/View/PaymentView.elm b/src/client/Model/View/PaymentView.elm
index cea7d2e..8de005d 100644
--- a/src/client/Model/View/PaymentView.elm
+++ b/src/client/Model/View/PaymentView.elm
@@ -6,14 +6,16 @@ module Model.View.PaymentView
 import Model.Payment exposing (Payments)
 
 type alias PaymentView =
-  { name : String
+  { userName : String
+  , name : String
   , cost : String
   , payments : Payments
   }
 
-initPaymentView : Payments -> PaymentView
-initPaymentView payments =
-  { name = ""
+initPaymentView : String -> Payments -> PaymentView
+initPaymentView userName payments =
+  { userName = userName
+  , name = ""
   , cost = ""
   , payments = payments
   }
diff --git a/src/client/Native/Reads.js b/src/client/Native/Reads.js
new file mode 100644
index 0000000..52590f9
--- /dev/null
+++ b/src/client/Native/Reads.js
@@ -0,0 +1,27 @@
+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 Result = Elm.Result.make(localRuntime);
+
+  function div(a, b)
+  {
+    return (a/b)|0;
+  }
+
+  function readInt(str) {
+    var number = Number(str);
+    return isNaN(number)
+             ? Result.Err("unable to parse '" + str + "' as a number")
+             : Result.Ok(number);
+  }
+
+  return localRuntime.Native.Reads.values = {
+    readInt: readInt
+  };
+};
diff --git a/src/client/Reads.elm b/src/client/Reads.elm
new file mode 100644
index 0000000..7bc1bbc
--- /dev/null
+++ b/src/client/Reads.elm
@@ -0,0 +1,10 @@
+module Reads
+  ( readInt
+  ) where
+
+
+import Native.Reads
+import Result exposing (Result)
+
+readInt : String -> Result String Int
+readInt = Native.Reads.readInt
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
index d763e29..ccf63f2 100644
--- a/src/client/ServerCommunication.elm
+++ b/src/client/ServerCommunication.elm
@@ -5,18 +5,21 @@ module ServerCommunication
   ) where
 
 import Signal
-import Task
-import Task exposing (Task)
+import Task as Task exposing (Task)
 import Http
 import Json.Decode exposing (..)
+import Date
+
+import Model.Message exposing (messageDecoder)
 
 import Update as U
 import Update.SignIn exposing (..)
+import Update.Payment as UP
 
 type Communication =
   NoCommunication
   | SignIn String
-  | AddPayment String String
+  | AddPayment String Int
   | SignOut
 
 serverCommunications : Signal.Mailbox Communication
@@ -47,7 +50,7 @@ getRequest communication =
       Just
         { verb = "post"
         , headers = []
-        , url = "/payment/add?name=" ++ name ++ "&cost=" ++ cost
+        , url = "/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost)
         , body = Http.empty
         }
     SignOut ->
@@ -67,8 +70,8 @@ communicationToAction communication response =
           U.NoOp
         SignIn login ->
           U.UpdateSignIn (ValidLogin login)
-        AddPayment _ _ ->
-          U.NoOp
+        AddPayment name cost ->
+          U.UpdatePayment (UP.AddPayment name cost)
         SignOut ->
           U.GoSignInView
     else
@@ -86,7 +89,7 @@ decodeResponse : Http.Response -> (String -> U.Action) -> U.Action
 decodeResponse response responseToAction =
   case response.value of
     Http.Text text ->
-      case decodeString ("message" := string) text of
+      case decodeString messageDecoder text of
         Ok x ->
           responseToAction x
         Err _ ->
diff --git a/src/client/Update.elm b/src/client/Update.elm
index f88a3a2..be7538a 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -4,6 +4,8 @@ module Update
   , updateModel
   ) where
 
+import Time exposing (Time)
+
 import Model exposing (Model)
 import Model.Payment exposing (Payments)
 import Model.View as V
@@ -15,10 +17,11 @@ import Update.Payment exposing (..)
 
 type Action =
   NoOp
+  | UpdateTime Time
   | GoSignInView
   | SignInError String
   | UpdateSignIn SignInAction
-  | GoPaymentView Payments
+  | GoPaymentView String Payments
   | UpdatePayment PaymentAction
 
 actions : Signal.Mailbox Action
@@ -29,10 +32,12 @@ updateModel action model =
   case action of
     NoOp ->
       model
+    UpdateTime time ->
+      { model | currentTime <- time }
     GoSignInView ->
       { model | view <- V.SignInView initSignInView }
-    GoPaymentView payments ->
-      { model | view <- V.PaymentView (initPaymentView payments) }
+    GoPaymentView userName payments ->
+      { model | view <- V.PaymentView (initPaymentView userName payments) }
     SignInError msg ->
       let signInView = { initSignInView | result <- Just (Err msg) }
       in  { model | view <- V.SignInView signInView }
@@ -45,6 +50,6 @@ updateModel action model =
     UpdatePayment paymentAction ->
       case model.view of
         V.PaymentView paymentView ->
-          { model | view <- V.PaymentView (updatePayment paymentAction paymentView) }
+          { model | view <- V.PaymentView (updatePayment model paymentAction paymentView) }
         _ ->
           model
diff --git a/src/client/Update/Payment.elm b/src/client/Update/Payment.elm
index 129ccde..136f0f9 100644
--- a/src/client/Update/Payment.elm
+++ b/src/client/Update/Payment.elm
@@ -3,6 +3,9 @@ module Update.Payment
   , updatePayment
   ) where
 
+import Date
+
+import Model exposing (Model)
 import Model.View.PaymentView exposing (..)
 import Model.Payment exposing (..)
 
@@ -10,9 +13,10 @@ type PaymentAction =
   UpdateName String
   | UpdateCost String
   | UpdatePayments Payments
+  | AddPayment String Int
 
-updatePayment : PaymentAction -> PaymentView -> PaymentView
-updatePayment action paymentView =
+updatePayment : Model -> PaymentAction -> PaymentView -> PaymentView
+updatePayment model action paymentView =
   case action of
     UpdateName name ->
       { paymentView | name <- name }
@@ -20,3 +24,15 @@ updatePayment action paymentView =
       { paymentView | cost <- cost }
     UpdatePayments payments ->
       { paymentView | payments <- payments }
+    AddPayment name cost ->
+      let payment =
+            { creation = Date.fromTime model.currentTime
+            , name = name
+            , cost = cost
+            , userName = paymentView.userName
+            }
+      in  { paymentView
+          | payments <- payment :: paymentView.payments
+          , name <- ""
+          , cost <- ""
+          }
diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm
new file mode 100644
index 0000000..1eb9027
--- /dev/null
+++ b/src/client/View/Events.elm
@@ -0,0 +1,19 @@
+module View.Events
+  ( onSubmitPrevDefault
+  ) where
+
+import Signal
+import Json.Decode as Json
+import Html exposing (..)
+import Html.Events exposing (..)
+import Html.Attributes exposing (..)
+
+onSubmitPrevDefault : Signal.Address a -> a -> Attribute
+onSubmitPrevDefault address value =
+  onWithOptions
+    "submit"
+    { defaultOptions | preventDefault <- True }
+    Json.value
+    (\_ ->
+      Signal.message address value
+    )
diff --git a/src/client/View/Payments/Add.elm b/src/client/View/Payments/Add.elm
index f2230be..32010ef 100644
--- a/src/client/View/Payments/Add.elm
+++ b/src/client/View/Payments/Add.elm
@@ -2,20 +2,28 @@ module View.Payments.Add
   ( addPayment
   ) where
 
-import Html exposing (..)
+import Html as H exposing (..)
 import Html.Attributes exposing (..)
 import Html.Events exposing (..)
+import Reads exposing (readInt)
+import Result exposing (..)
 
-import ServerCommunication as SC
-import ServerCommunication exposing (serverCommunications)
+import ServerCommunication as SC exposing (serverCommunications)
 
 import Update exposing (..)
 import Update.Payment exposing (..)
 
+import View.Events exposing (onSubmitPrevDefault)
+
 addPayment : String -> String -> Html
 addPayment name cost =
-  div
-    [ class "add" ]
+  H.form
+    [ class "add"
+    , onSubmitPrevDefault serverCommunications.address
+        <| case readInt cost of
+             Ok number -> SC.AddPayment name number
+             Err _ -> SC.NoCommunication
+    ]
     [ text "Name"
     , input
         [ value name
@@ -29,6 +37,6 @@ addPayment name cost =
         ]
         []
     , button
-        [ onClick serverCommunications.address (SC.AddPayment name cost) ]
+        [ type' "submit" ]
         [ text "Add" ]
     ]
diff --git a/src/client/View/SignIn.elm b/src/client/View/SignIn.elm
index 02ee1bd..a45adc7 100644
--- a/src/client/View/SignIn.elm
+++ b/src/client/View/SignIn.elm
@@ -2,7 +2,7 @@ module View.SignIn
   ( renderSignIn
   ) where
 
-import Html exposing (..)
+import Html as H exposing (..)
 import Html.Attributes exposing (..)
 import Html.Events exposing (..)
 
@@ -16,20 +16,21 @@ import ServerCommunication exposing (serverCommunications)
 
 import Model.View.SignInView exposing (..)
 
+import View.Events exposing (onSubmitPrevDefault)
+
 renderSignIn : SignInView -> Html
 renderSignIn signInView =
   div
     [ class "signIn" ]
-    [ div
-        [ class "form" ]
+    [ H.form
+        [ onSubmitPrevDefault serverCommunications.address (SC.SignIn signInView.login) ]
         [ input
             [ value signInView.login
             , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin)
-            , onEnter serverCommunications.address (SC.SignIn signInView.login)
             ]
             []
         , button
-            [ onClick serverCommunications.address (SC.SignIn signInView.login) ]
+            []
             [ text "Sign in" ]
         ]
     , div
@@ -37,12 +38,6 @@ renderSignIn signInView =
         [ signInResult signInView ]
     ]
 
-onEnter : Signal.Address a -> a -> Attribute
-onEnter address value =
-  on "keydown"
-    (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err ""))
-    (\_ -> Signal.message address value)
-
 signInResult : SignInView -> Html
 signInResult signInView =
   case signInView.result of
diff --git a/src/server/Application.hs b/src/server/Application.hs
index 24342dc..59aa252 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -3,13 +3,15 @@
 module Application
   ( signInAction
   , validateSignInAction
+  , getUserName
+  , getPaymentsAction
+  , createPaymentAction
   , signOutAction
+
   , getIndexAction
   , getUsersAction
-  , getPaymentsAction
   , addUserAction
   , deleteUserAction
-  , createPaymentAction
   ) where
 
 import Web.Scotty
@@ -44,44 +46,6 @@ import View.Page (page)
 
 import Mail
 
-getIndexAction :: ActionM ()
-getIndexAction = html page
-
-getUsersAction :: ActionM ()
-getUsersAction = do
-  users <- liftIO $ runDb getUsers
-  html . fromString . show $ users
-
-getPaymentsAction :: ActionM ()
-getPaymentsAction =
-  Secure.loggedAction (\_ -> do
-    payments <- liftIO $ runDb getPayments
-    json payments
-  )
-
-addUserAction :: Text -> Text -> ActionM ()
-addUserAction email name = do
-  _ <- liftIO . runDb $ createUser email name
-  status ok200
-
-deleteUserAction :: Text -> ActionM ()
-deleteUserAction email = do
-  _ <- liftIO . runDb $ deleteUser email
-  status ok200
-
-createPaymentAction :: Text -> Int -> ActionM ()
-createPaymentAction name cost =
-  Secure.loggedAction (\login -> do
-    maybeUser <- liftIO . runDb $ getUser login
-    case maybeUser of
-      Just user -> do
-        _ <- liftIO . runDb $ createPayment (entityKey user) name cost
-        return ()
-      Nothing -> do
-        status badRequest400
-        status ok200
-  )
-
 signInAction :: Text -> ActionM ()
 signInAction login =
   if isValid (TE.encodeUtf8 login)
@@ -129,6 +93,26 @@ redirectError :: Text -> ActionM ()
 redirectError msg =
   redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
 
+getUserName :: ActionM ()
+getUserName =
+  Secure.loggedAction (\user -> do
+    json . Message . userName . entityVal $ user
+  )
+
+getPaymentsAction :: ActionM ()
+getPaymentsAction =
+  Secure.loggedAction (\_ -> do
+    payments <- liftIO $ runDb getPayments
+    json payments
+  )
+
+createPaymentAction :: Text -> Int -> ActionM ()
+createPaymentAction name cost =
+  Secure.loggedAction (\user -> do
+    _ <- liftIO . runDb $ createPayment (entityKey user) name cost
+    return ()
+  )
+
 signOutAction :: ActionM ()
 signOutAction = do
   LoginSession.delete
@@ -138,3 +122,25 @@ errorResponse :: Text -> ActionM ()
 errorResponse msg = do
   status badRequest400
   json (Message msg)
+
+
+
+
+
+getIndexAction :: ActionM ()
+getIndexAction = html page
+
+getUsersAction :: ActionM ()
+getUsersAction = do
+  users <- liftIO $ runDb getUsers
+  html . fromString . show $ users
+
+addUserAction :: Text -> Text -> ActionM ()
+addUserAction email name = do
+  _ <- liftIO . runDb $ createUser email name
+  status ok200
+
+deleteUserAction :: Text -> ActionM ()
+deleteUserAction email = do
+  _ <- liftIO . runDb $ deleteUser email
+  status ok200
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 9d096e4..1f35732 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -74,7 +74,7 @@ global = do
 
   ".signIn" ? do
 
-    ".form" ? do
+    form ? do
       let inputHeight = 50
       width (px 500)
       marginTop (px 50)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index d534c4e..2ae319b 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -29,6 +29,9 @@ main = do
       token <- param "token" :: ActionM Text
       validateSignInAction token
 
+    get "/userName" $
+      getUserName
+
     get "/payments" $
       getPaymentsAction
 
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 94ee8a9..1fef713 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -8,16 +8,31 @@ import Web.Scotty
 
 import Network.HTTP.Types.Status (forbidden403)
 
-import Data.Text (Text)
+import Database.Persist (Entity)
+
+import Model.Database (User, runDb)
+import Model.User (getUser)
+
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
 
 import qualified LoginSession
 
-loggedAction :: (Text -> ActionM ()) -> ActionM ()
+loggedAction :: (Entity User -> ActionM ()) -> ActionM ()
 loggedAction action = do
   maybeLogin <- LoginSession.get
   case maybeLogin of
-    Just login ->
-      action login
+    Just login -> do
+      maybeUser <- liftIO . runDb $ getUser login
+      case maybeUser of
+        Just user ->
+          action user
+        Nothing -> do
+          status forbidden403
+          liftIO . TIO.putStrLn . T.concat $ ["Could not find the user which login is ", login]
+          html "Could not find a user from your login"
     Nothing -> do
       status forbidden403
       html "You need to be logged in to perform this action"
-- 
cgit v1.2.3