blob: 75d03230789d65086e2db766b1b4aff7671ab559 (
plain)
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
|
{-# 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 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 Data.String (fromString)
import qualified LoginSession
import qualified Secure
import Model.Database
import Model.User
import Model.Payment
import Model.SignIn
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 = 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 ->
status badRequest400
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
|