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
|
{-# 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.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
import Model.Database
import Model.User
import Model.Payment
import Model.SignIn
import Model.Message
import View.Page (page)
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]
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
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
|
