aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/Model/View/SignIn.elm4
-rw-r--r--src/client/ServerCommunication.elm26
-rw-r--r--src/client/Update/SignIn.elm9
-rw-r--r--src/client/View/Page.elm47
-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
9 files changed, 125 insertions, 46 deletions
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"
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-28 00:39:37 +0000