1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
{-# LANGUAGE OverloadedStrings #-}
module Application
( signInAction
, validateSignInAction
, getUserName
, getPaymentsAction
, createPaymentAction
, signOutAction
, getIndexAction
, getUsersAction
, addUserAction
, deleteUserAction
) where
import Web.Scotty
import Network.HTTP.Types.Status (ok200, badRequest400)
import Network.Wai (requestHeaderHost)
import Database.Persist
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import Data.String (fromString)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Text.Email.Validate (isValid)
import qualified LoginSession
import qualified Secure
import Model.Database
import Model.User
import Model.Payment
import Model.SignIn
import Model.Message
import View.Page (page)
import Mail
signInAction :: Text -> ActionM ()
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]
let mail = Mail [login] "Sign in" url url
maybeSentMail <- liftIO . sendMail $ mail
case maybeSentMail of
Right _ ->
status ok200
Left _ ->
errorResponse "Sorry, we failed to send you the sign up email."
_ ->
errorResponse "You are not authorized to sign in."
else
errorResponse "Please enter a valid email address."
validateSignInAction :: Text -> ActionM ()
validateSignInAction token = do
maybeSignIn <- liftIO . runDb $ getSignInToken token
now <- liftIO getCurrentTime
case maybeSignIn of
Just signIn ->
if signInIsUsed . entityVal $ signIn
then
redirectError "The token has already been used."
else
let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
in if diffTime > 2 * 60 -- 2 minutes
then
redirectError "The token has expired."
else do
LoginSession.put (signInEmail . entityVal $ signIn)
liftIO . runDb . signInTokenToUsed . entityKey $ signIn
redirect "/"
Nothing ->
redirectError "The token is invalid."
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
status ok200
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
|
