Adding a 2 minutes expiration time for a login token

2 files changed, 25 insertions, 18 deletions

diff --git a/src/server/Application.hs b/src/server/Application.hs
index 7bb305e..739fe33 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -25,6 +25,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import Data.String (fromString)
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
 
 import Text.Email.Validate (isValid)
 
@@ -100,23 +101,33 @@ signInAction login =
     else
       errorResponse "Please enter a valid email address."
 
-errorResponse :: Text -> ActionM ()
-errorResponse message = do
-  status badRequest400
-  json (Message message)
-
 validateSignInAction :: Text -> ActionM ()
 validateSignInAction token = do
   maybeSignIn <- liftIO . runDb $ getSignInToken token
+  now <- liftIO getCurrentTime
   case maybeSignIn of
-    Just signIn -> do
-      LoginSession.put (signInEmail . entityVal $ signIn)
-      liftIO . runDb . signInTokenIsUsed . entityKey $ signIn
-      redirect "/"
+    Just signIn ->
+      if signInIsUsed . entityVal $ signIn
+        then
+          errorResponse "The token has already been used."
+        else
+          let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
+          in  if diffTime > 2 * 60 -- 2 minutes
+                then
+                  errorResponse "The token has expired."
+                else do
+                  LoginSession.put (signInEmail . entityVal $ signIn)
+                  liftIO . runDb . signInTokenToUsed . entityKey $ signIn
+                  redirect "/"
     Nothing ->
-      status badRequest400
+      errorResponse "The token is invalid."
 
 signOutAction :: ActionM ()
 signOutAction = do
   LoginSession.delete
   status ok200
+
+errorResponse :: Text -> ActionM ()
+errorResponse msg = do
+  status badRequest400
+  json (Message msg)
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
index c447416..0f9c6ce 100644
--- a/src/server/Model/SignIn.hs
+++ b/src/server/Model/SignIn.hs
@@ -1,7 +1,7 @@
 module Model.SignIn
   ( createSignInToken
   , getSignInToken
-  , signInTokenIsUsed
+  , signInTokenToUsed
   ) where
 
 import Data.Text (Text)
@@ -23,12 +23,8 @@ createSignInToken email = do
 
 getSignInToken :: Text -> Persist (Maybe (Entity SignIn))
 getSignInToken token =
-  selectFirst
-    [ SignInToken ==. token
-    , SignInIsUsed ==. False
-    ]
-    []
+  selectFirst [SignInToken ==. token] []
 
-signInTokenIsUsed :: SignInId -> Persist ()
-signInTokenIsUsed tokenId =
+signInTokenToUsed :: SignInId -> Persist ()
+signInTokenToUsed tokenId =
   update tokenId [SignInIsUsed =. True]