aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Application.hs30
-rw-r--r--src/server/Design/Color.hs3
-rw-r--r--src/server/Design/Global.hs48
-rw-r--r--src/server/Model/Message.hs2
-rw-r--r--src/server/View/Page.hs2
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"