From 331d506281760ac62e8f1715ef729e1b2a91e280 Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Sun, 19 Jul 2015 17:28:19 +0200
Subject: Showing either error or success message at sign in page

---
 src/client/Model/View/SignIn.elm   |  4 ++--
 src/client/ServerCommunication.elm | 26 +++++++++++++++++++--
 src/client/Update/SignIn.elm       |  9 +++++++
 src/client/View/Page.elm           | 47 +++++++++++++++++++++++++++----------
 src/server/Application.hs          | 30 +++++++++++++++++-------
 src/server/Design/Color.hs         |  3 +++
 src/server/Design/Global.hs        | 48 +++++++++++++++++++++++---------------
 src/server/Model/Message.hs        |  2 +-
 src/server/View/Page.hs            |  2 +-
 9 files changed, 125 insertions(+), 46 deletions(-)

(limited to 'src')

diff --git a/src/client/Model/View/SignIn.elm b/src/client/Model/View/SignIn.elm
index 1c8eae7..0a973e2 100644
--- a/src/client/Model/View/SignIn.elm
+++ b/src/client/Model/View/SignIn.elm
@@ -5,11 +5,11 @@ module Model.View.SignIn
 
 type alias SignIn =
   { login : String
-  , authentication : Maybe (Result String String)
+  , result : Maybe (Result String String)
   }
 
 initSignIn : SignIn
 initSignIn =
   { login = ""
-  , authentication = Nothing
+  , result = Nothing
   }
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
index e29b084..d581f82 100644
--- a/src/client/ServerCommunication.elm
+++ b/src/client/ServerCommunication.elm
@@ -8,8 +8,10 @@ import Signal
 import Task
 import Task exposing (Task)
 import Http
+import Json.Decode exposing (..)
 
 import Update as U
+import Update.SignIn exposing (..)
 
 type Communication =
   NoCommunication
@@ -55,9 +57,29 @@ communicationToAction communication response =
       case communication of
         NoCommunication ->
           U.NoOp
-        SignIn _ ->
-          U.NoOp
+        SignIn login ->
+          U.UpdateSignIn (ValidLogin login)
         SignOut ->
           U.SignIn
     else
+      decodeResponse
+        response
+        (\error ->
+          case communication of
+            SignIn _ ->
+              U.UpdateSignIn (ErrorLogin error)
+            _ ->
+              U.NoOp
+        )
+
+decodeResponse : Http.Response -> (String -> U.Action) -> U.Action
+decodeResponse response responseToAction =
+  case response.value of
+    Http.Text text ->
+      case decodeString ("message" := string) text of
+        Ok x ->
+          responseToAction x
+        Err _ ->
+          U.NoOp
+    Http.Blob _ ->
       U.NoOp
diff --git a/src/client/Update/SignIn.elm b/src/client/Update/SignIn.elm
index a962f90..0e118dc 100644
--- a/src/client/Update/SignIn.elm
+++ b/src/client/Update/SignIn.elm
@@ -7,9 +7,18 @@ import Model.View.SignIn exposing (..)
 
 type SignInAction =
   UpdateLogin String
+  | ValidLogin String
+  | ErrorLogin String
 
 updateSignIn : SignInAction -> SignIn -> SignIn
 updateSignIn action signIn =
   case action of
     UpdateLogin login ->
       { signIn | login <- login }
+    ValidLogin message ->
+      { signIn
+      | login <- ""
+      , result <- Just (Ok message)
+      }
+    ErrorLogin message ->
+      { signIn | result <- Just (Err message) }
diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm
index eb86132..bf61dc1 100644
--- a/src/client/View/Page.elm
+++ b/src/client/View/Page.elm
@@ -18,6 +18,7 @@ import Json.Decode as Json
 import Model exposing (Model)
 import Model.Payment exposing (Payments, Payment)
 import Model.View exposing (..)
+import Model.View.SignIn exposing (..)
 
 import Update exposing (..)
 import Update.SignIn exposing (..)
@@ -60,27 +61,33 @@ renderMain model =
   case model.view of
     LoadingView ->
       loadingView
-    SignInView { login } ->
-      signInView login
+    SignInView signIn ->
+      signInView signIn
     PaymentView payments ->
       paymentsView payments
 
 loadingView : Html
 loadingView = text ""
 
-signInView : String -> Html
-signInView login =
+signInView : SignIn -> Html
+signInView signIn =
   div
     [ class "signIn" ]
-    [ input
-        [ value login
-        , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin)
-        , onEnter serverCommunications.address (SC.SignIn login)
+    [ div
+        [ class "form" ]
+        [ input
+            [ value signIn.login
+            , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin)
+            , onEnter serverCommunications.address (SC.SignIn signIn.login)
+            ]
+            []
+        , button
+            [ onClick serverCommunications.address (SC.SignIn signIn.login) ]
+            [ text "Sign in" ]
         ]
-        []
-    , button
-        [ onClick serverCommunications.address (SC.SignIn login) ]
-        [ text "Sign in" ]
+    , div
+        [ class "result" ]
+        [ signInResult signIn ]
     ]
 
 onEnter : Signal.Address a -> a -> Attribute
@@ -89,6 +96,22 @@ onEnter address value =
     (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err ""))
     (\_ -> Signal.message address value)
 
+signInResult : SignIn -> Html
+signInResult signIn =
+  case signIn.result of
+    Just result ->
+      case result of
+        Ok login ->
+          div
+            [ class "success" ]
+            [ text ("We send you an email, please click to the provided link in order to sign in.") ]
+        Err error ->
+          div
+            [ class "error" ]
+            [ text error ]
+    Nothing ->
+      text ""
+
 paymentsView : Payments -> Html
 paymentsView payments =
   table
diff --git a/src/server/Application.hs b/src/server/Application.hs
index 75d0323..6a18102 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -15,6 +15,7 @@ module Application
 import Web.Scotty
 
 import Network.HTTP.Types.Status (ok200, badRequest400)
+import Network.Wai (requestHeaderHost)
 
 import Database.Persist
 
@@ -23,8 +24,11 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
+import qualified Data.Text.Encoding as TE
 import Data.String (fromString)
 
+import Text.Email.Validate (isValid)
+
 import qualified LoginSession
 
 import qualified Secure
@@ -33,6 +37,7 @@ import Model.Database
 import Model.User
 import Model.Payment
 import Model.SignIn
+import Model.Message
 
 import View.Page (page)
 
@@ -73,16 +78,23 @@ createPaymentAction email name cost = do
       status ok200
 
 signInAction :: Text -> ActionM ()
-signInAction login = do
-  maybeUser <- liftIO . runDb $ getUser login
-  case maybeUser of
-    Just _ -> do
-      token <- liftIO . runDb $ createSignInToken login
-      let url = T.concat ["http://localhost:3000/validateSignIn?token=", token]
-      liftIO . TIO.putStrLn $ url
-      status ok200
-    Nothing ->
+signInAction login =
+  if isValid (TE.encodeUtf8 login)
+    then do
+      maybeUser <- liftIO . runDb $ getUser login
+      maybeHost <- fmap TE.decodeUtf8 . requestHeaderHost <$> request
+      case (maybeUser, maybeHost) of
+        (Just _, Just host) -> do
+          token <- liftIO . runDb $ createSignInToken login
+          let url = T.concat ["http://", host ,"/validateSignIn?token=", token]
+          liftIO . TIO.putStrLn $ url
+          status ok200
+        _ -> do
+          status badRequest400
+          json (Message "You are not authorized to sign in.")
+    else do
       status badRequest400
+      json (Message "Please enter a valid email address.")
 
 validateSignInAction :: Text -> ActionM ()
 validateSignInAction token = do
diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs
index b744cf2..a9529ab 100644
--- a/src/server/Design/Color.hs
+++ b/src/server/Design/Color.hs
@@ -5,6 +5,9 @@ import qualified Clay.Color as C
 white :: C.Color
 white = C.white
 
+red :: C.Color
+red = C.red
+
 brown :: C.Color
 brown = C.brown
 
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 6e3cbe6..6985174 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -68,22 +68,32 @@ global = do
       nthChild "odd" & backgroundColor C.lightGrey
 
   ".signIn" ? do
-    let inputHeight = 50
-    width (px 500)
-    marginTop (px 50)
-    marginLeft auto
-    marginRight auto
-    input ? do
-      display block
-      width (pct 100)
-      padding (px 10) (px 10) (px 10) (px 10)
-      height (px inputHeight)
-      marginBottom (px 10)
-    button ? do
-      display block
-      width (pct 100)
-      height (px inputHeight)
-      backgroundColor C.brown
-      color C.white
-      borderWidth (px 0)
-      borderRadius (px 3) (px 3) (px 3) (px 3)
+
+    ".form" ? do
+      let inputHeight = 50
+      width (px 500)
+      marginTop (px 50)
+      marginLeft auto
+      marginRight auto
+
+      input ? do
+        display block
+        width (pct 100)
+        padding (px 10) (px 10) (px 10) (px 10)
+        height (px inputHeight)
+        marginBottom (px 10)
+
+      button ? do
+        display block
+        width (pct 100)
+        height (px inputHeight)
+        backgroundColor C.brown
+        color C.white
+        borderWidth (px 0)
+        borderRadius (px 3) (px 3) (px 3) (px 3)
+
+    ".result" ? do
+      marginTop (px 40)
+      textAlign (alignSide sideCenter)
+      ".success" ? color C.green
+      ".error" ? color C.red
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
index acc785e..6b4287e 100644
--- a/src/server/Model/Message.hs
+++ b/src/server/Model/Message.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 
-module Model.Message.Json
+module Model.Message
   ( Message(..)
   ) where
 
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index 3f4dbf5..b5a80e2 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -19,7 +19,7 @@ page =
   renderHtml . docTypeHtml $ do
     H.head $ do
       meta ! charset "UTF-8"
-      H.title "Payments"
+      H.title "Shared Cost"
       script ! src "/javascripts/client.js" $ ""
       link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
       link ! rel "stylesheet" ! href "/css/font-awesome/css/font-awesome.min.css"
-- 
cgit v1.2.3