From a7db22556b91bc7c499e010b4c051f4442ad8ce2 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 29 Dec 2015 22:38:42 +0100
Subject: Using persona to validate emails

---
 src/server/Controller/SignIn.hs | 84 +++++++----------------------------------
 1 file changed, 14 insertions(+), 70 deletions(-)

(limited to 'src/server/Controller/SignIn.hs')

diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 31cd510..8eceb56 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -2,32 +2,21 @@
 
 module Controller.SignIn
   ( signIn
-  , validateSignIn
   ) where
 
 import Web.Scotty
 
 import Network.HTTP.Types.Status (ok200)
 
-import Database.Persist
-
 import Control.Monad.IO.Class (liftIO)
 
 import Data.Text (Text)
-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 Data.Maybe (isJust)
 
 import qualified LoginSession
 
 import Config
 
-import SendMail
-
-import Text.Email.Validate as Email
-
 import Model.Database
 import Model.User
 import Model.SignIn
@@ -36,65 +25,20 @@ import Model.Message (getMessage)
 
 import Json (jsonError)
 
-import Secure (getUserFromToken)
-
-import qualified View.Mail.SignIn as SignIn
+import Persona (verifyEmail)
 
 signIn :: Config -> Text -> ActionM ()
-signIn config login =
-  if Email.isValid (TE.encodeUtf8 login)
-    then do
-      maybeUser <- liftIO . runDb $ getUser login
-      case maybeUser of
-        Just user -> do
-          token <- liftIO . runDb $ createSignInToken login
-          let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token]
-          maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login]
-          case maybeSentMail of
-            Right _ ->
-              status ok200
-            Left _ ->
-              jsonError (getMessage SendEmailFail)
-        Nothing ->
-            jsonError (getMessage Unauthorized)
-    else
-      jsonError (getMessage EnterValidEmail)
-
-validateSignIn :: Config -> Text -> ActionM ()
-validateSignIn config textToken = do
-  alreadySigned <- isAlreadySigned
-  if alreadySigned
-    then
-      redirect "/"
-    else do
-      mbSignIn <- liftIO . runDb $ getSignInToken textToken
-      now <- liftIO getCurrentTime
-      case mbSignIn of
-        Just signIn ->
-          if signInIsUsed . entityVal $ signIn
-            then
-              redirectError (getMessage SignInUsed)
-            else
-              let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
-              in  if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
-                    then
-                      redirectError (getMessage SignInExpired)
-                    else do
-                      LoginSession.put (signInToken . entityVal $ signIn)
-                      liftIO . runDb . signInTokenToUsed . entityKey $ signIn
-                      redirect "/"
-        Nothing ->
-          redirectError (getMessage SignInInvalid)
-
-isAlreadySigned :: ActionM Bool
-isAlreadySigned = do
-  mbToken <- LoginSession.get
-  case mbToken of
+signIn config assertion = do
+  mbEmail <- liftIO $ verifyEmail config assertion
+  case mbEmail of
     Nothing ->
-      return False
-    Just token -> do
-      liftIO . runDb . fmap isJust $ getUserFromToken token
-
-redirectError :: Text -> ActionM ()
-redirectError msg =
-  redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
+      jsonError (getMessage InvalidEmail)
+    Just email -> do
+      isAuthorized <- liftIO . fmap isJust . runDb $ getUser email
+      if isAuthorized
+        then do
+          token <- liftIO . runDb $ createSignInToken email
+          LoginSession.put token
+          status ok200
+        else
+          jsonError (getMessage Unauthorized)
-- 
cgit v1.2.3