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
|
{-# LANGUAGE OverloadedStrings #-}
module Application
( signInAction
, validateSignInAction
, signOutAction
, getIndexAction
, getUsersAction
, getPaymentsAction
, addUserAction
, deleteUserAction
, createPaymentAction
) 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.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
getIndexAction :: ActionM ()
getIndexAction = html page
getUsersAction :: ActionM ()
getUsersAction = do
users <- liftIO $ runDb getUsers
html . fromString . show $ users
getPaymentsAction :: ActionM ()
getPaymentsAction =
Secure.loggedAction (\_ -> do
payments <- liftIO $ runDb getPayments
json payments
)
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
createPaymentAction :: Text -> Text -> Int -> ActionM ()
createPaymentAction email name cost = do
maybeUser <- liftIO . runDb $ getUser email
case maybeUser of
Just user -> do
_ <- liftIO . runDb $ createPayment (entityKey user) name cost
return ()
Nothing -> do
status badRequest400
status ok200
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
errorResponse "The token has already been used."
else
let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
in if diffTime > 2 * 60 -- 2 minutes
then
errorResponse "The token has expired."
else do
LoginSession.put (signInEmail . entityVal $ signIn)
liftIO . runDb . signInTokenToUsed . entityKey $ signIn
redirect "/"
Nothing ->
errorResponse "The token is invalid."
signOutAction :: ActionM ()
signOutAction = do
LoginSession.delete
status ok200
errorResponse :: Text -> ActionM ()
errorResponse msg = do
status badRequest400
json (Message msg)
|