Showing either error or success message at sign in page

5 files changed, 55 insertions, 30 deletions

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"