aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Payment.hs11
-rw-r--r--src/server/Controller/SignIn.hs22
-rw-r--r--src/server/Json.hs14
-rw-r--r--src/server/Model/SignIn.hs10
-rw-r--r--src/server/Secure.hs29
5 files changed, 55 insertions, 31 deletions
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index ffb575c..d233aa2 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -10,22 +10,20 @@ module Controller.Payment
import Web.Scotty
-import Network.HTTP.Types.Status (ok200, badRequest400)
+import Network.HTTP.Types.Status (ok200)
import Database.Persist
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
-import qualified Data.Aeson.Types as Json
import qualified Secure
-import Json (jsonObject)
+import Json (jsonError)
import Model.Database
import qualified Model.Payment as P
-import qualified Model.Payer as Payer
import Model.Frequency
import Model.Json.Number
import qualified Model.Json.PaymentId as JP
@@ -58,9 +56,8 @@ deletePayment paymentId =
if deleted
then
status ok200
- else do
- status badRequest400
- jsonObject [("error", Json.String $ getMessage PaymentNotDeleted)]
+ else
+ jsonError (getMessage PaymentNotDeleted)
)
getPaymentsCount :: ActionM ()
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 3bbb9ff..5306ee1 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -7,7 +7,7 @@ module Controller.SignIn
import Web.Scotty
-import Network.HTTP.Types.Status (ok200, badRequest400)
+import Network.HTTP.Types.Status (ok200)
import Database.Persist
@@ -18,7 +18,6 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (getCurrentTime, diffUTCTime)
-import qualified Data.Aeson.Types as Json
import qualified LoginSession
@@ -26,7 +25,7 @@ import Config
import SendMail
-import Text.Email.Validate (isValid)
+import Text.Email.Validate as Email
import Model.Database
import Model.User
@@ -34,13 +33,13 @@ import Model.SignIn
import Model.Message.Key
import Model.Message (getMessage)
-import Json (jsonObject)
+import Json (jsonError)
import qualified View.Mail.SignIn as SignIn
signIn :: Config -> Text -> ActionM ()
signIn config login =
- if isValid (TE.encodeUtf8 login)
+ if Email.isValid (TE.encodeUtf8 login)
then do
maybeUser <- liftIO . runDb $ getUser login
case maybeUser of
@@ -52,16 +51,11 @@ signIn config login =
Right _ ->
status ok200
Left _ ->
- errorResponse (getMessage SendEmailFail)
+ jsonError (getMessage SendEmailFail)
Nothing ->
- errorResponse (getMessage Unauthorized)
+ jsonError (getMessage Unauthorized)
else
- errorResponse (getMessage EnterValidEmail)
-
-errorResponse :: Text -> ActionM ()
-errorResponse msg = do
- status badRequest400
- jsonObject [("error", Json.String msg)]
+ jsonError (getMessage EnterValidEmail)
validateSignIn :: Config -> Text -> ActionM ()
validateSignIn config textToken = do
@@ -78,7 +72,7 @@ validateSignIn config textToken = do
then
redirectError (getMessage SignInExpired)
else do
- LoginSession.put (signInEmail . entityVal $ token)
+ LoginSession.put (signInToken . entityVal $ token)
liftIO . runDb . signInTokenToUsed . entityKey $ token
redirect "/"
Nothing ->
diff --git a/src/server/Json.hs b/src/server/Json.hs
index 51287ed..bd5ac3e 100644
--- a/src/server/Json.hs
+++ b/src/server/Json.hs
@@ -1,12 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Json
- ( jsonObject
+ ( jsonError
+ , jsonObject
) where
-import Web.Scotty (json, ActionM)
+import Web.Scotty
+
+import Network.HTTP.Types.Status (badRequest400)
import qualified Data.Aeson.Types as Json
import qualified Data.HashMap.Strict as M
import Data.Text (Text)
+jsonError :: Text -> ActionM ()
+jsonError msg = do
+ status badRequest400
+ jsonObject [("error", Json.String msg)]
+
jsonObject :: [(Text, Json.Value)] -> ActionM ()
jsonObject = json . Json.Object . M.fromList
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
index 0f9c6ce..117b8b5 100644
--- a/src/server/Model/SignIn.hs
+++ b/src/server/Model/SignIn.hs
@@ -2,6 +2,7 @@ module Model.SignIn
( createSignInToken
, getSignInToken
, signInTokenToUsed
+ , isLastValidToken
) where
import Data.Text (Text)
@@ -28,3 +29,12 @@ getSignInToken token =
signInTokenToUsed :: SignInId -> Persist ()
signInTokenToUsed tokenId =
update tokenId [SignInIsUsed =. True]
+
+isLastValidToken :: SignIn -> Persist Bool
+isLastValidToken signIn = do
+ maybe False ((== (signInToken signIn)) . signInToken . entityVal) <$>
+ selectFirst
+ [ SignInEmail ==. (signInEmail signIn)
+ , SignInIsUsed ==. True
+ ]
+ [ Desc SignInCreation ]
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 1fef713..8565098 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -8,13 +8,15 @@ import Web.Scotty
import Network.HTTP.Types.Status (forbidden403)
-import Database.Persist (Entity)
+import Database.Persist (Entity, entityVal)
-import Model.Database (User, runDb)
import Model.User (getUser)
+import Model.SignIn (getSignInToken, isLastValidToken)
+import Model.Database
import Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
@@ -22,17 +24,28 @@ import qualified LoginSession
loggedAction :: (Entity User -> ActionM ()) -> ActionM ()
loggedAction action = do
- maybeLogin <- LoginSession.get
- case maybeLogin of
- Just login -> do
- maybeUser <- liftIO . runDb $ getUser login
+ maybeToken <- LoginSession.get
+ case maybeToken of
+ Just token -> do
+ maybeUser <- liftIO . runDb . getUserFromToken $ token
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"
+ html "You are not authorized to logged in"
Nothing -> do
status forbidden403
html "You need to be logged in to perform this action"
+
+getUserFromToken :: Text -> Persist (Maybe (Entity User))
+getUserFromToken token = do
+ mbSignIn <- fmap entityVal <$> getSignInToken token
+ case mbSignIn of
+ Just signIn -> do
+ isValid <- isLastValidToken signIn
+ if isValid
+ then getUser (signInEmail signIn)
+ else return Nothing
+ Nothing ->
+ return Nothing
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 05:28:29 +0000