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
|
{-# 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 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."
errorResponse :: Text -> ActionM ()
errorResponse message = do
status badRequest400
json (Message message)
validateSignInAction :: Text -> ActionM ()
validateSignInAction token = do
maybeSignIn <- liftIO . runDb $ getSignInToken token
case maybeSignIn of
Just signIn -> do
LoginSession.put (signInEmail . entityVal $ signIn)
liftIO . runDb . signInTokenIsUsed . entityKey $ signIn
redirect "/"
Nothing ->
status badRequest400
signOutAction :: ActionM ()
signOutAction = do
LoginSession.delete
status ok200
|
