Store the sign in token instead of the login in the session cookie

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