aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Application.hs86
-rw-r--r--src/server/Design/Global.hs2
-rw-r--r--src/server/Main.hs3
-rw-r--r--src/server/Secure.hs23
4 files changed, 69 insertions, 45 deletions
diff --git a/src/server/Application.hs b/src/server/Application.hs
index 24342dc..59aa252 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -3,13 +3,15 @@
module Application
( signInAction
, validateSignInAction
+ , getUserName
+ , getPaymentsAction
+ , createPaymentAction
, signOutAction
+
, getIndexAction
, getUsersAction
- , getPaymentsAction
, addUserAction
, deleteUserAction
- , createPaymentAction
) where
import Web.Scotty
@@ -44,44 +46,6 @@ 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 -> Int -> ActionM ()
-createPaymentAction name cost =
- Secure.loggedAction (\login -> do
- maybeUser <- liftIO . runDb $ getUser login
- 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)
@@ -129,6 +93,26 @@ 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
@@ -138,3 +122,25 @@ 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
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 9d096e4..1f35732 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -74,7 +74,7 @@ global = do
".signIn" ? do
- ".form" ? do
+ form ? do
let inputHeight = 50
width (px 500)
marginTop (px 50)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index d534c4e..2ae319b 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -29,6 +29,9 @@ main = do
token <- param "token" :: ActionM Text
validateSignInAction token
+ get "/userName" $
+ getUserName
+
get "/payments" $
getPaymentsAction
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 94ee8a9..1fef713 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -8,16 +8,31 @@ import Web.Scotty
import Network.HTTP.Types.Status (forbidden403)
-import Data.Text (Text)
+import Database.Persist (Entity)
+
+import Model.Database (User, runDb)
+import Model.User (getUser)
+
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
import qualified LoginSession
-loggedAction :: (Text -> ActionM ()) -> ActionM ()
+loggedAction :: (Entity User -> ActionM ()) -> ActionM ()
loggedAction action = do
maybeLogin <- LoginSession.get
case maybeLogin of
- Just login ->
- action login
+ Just login -> do
+ maybeUser <- liftIO . runDb $ getUser login
+ case maybeUser of
+ Just user ->
+ action user
+ Nothing -> do
+ status forbidden403
+ liftIO . TIO.putStrLn . T.concat $ ["Could not find the user which login is ", login]
+ html "Could not find a user from your login"
Nothing -> do
status forbidden403
html "You need to be logged in to perform this action"