From 9d57e149fcb124a28813c56f83cf254eb92baa42 Mon Sep 17 00:00:00 2001
From: Joris
Date: Fri, 11 Mar 2016 23:21:06 +0100
Subject: Don't use persona anymore, use email token to sign in

---
 src/server/Controller/SignIn.hs | 89 +++++++++++++++++++++++++++++++++--------
 1 file changed, 73 insertions(+), 16 deletions(-)

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

diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index ddd8852..1fb62ec 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -2,43 +2,100 @@
 
 module Controller.SignIn
   ( signIn
+  , validateSignIn
   ) where
 
 import Web.Scotty
 
-import Network.HTTP.Types.Status (ok200)
+import Network.HTTP.Types.Status (ok200, badRequest400)
+
+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
 import Model.Message.Key
 import Model.Message (getMessage)
 
-import Json (jsonError)
+import Secure (getUserFromToken)
 
-import Persona (verifyEmail)
+import qualified View.Mail.SignIn as SignIn
 
 signIn :: Config -> Text -> ActionM ()
-signIn config assertion = do
-  mbEmail <- liftIO $ verifyEmail config assertion
-  case mbEmail of
+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 _ -> do
+              status badRequest400
+              text (TL.pack $ show SendEmailFail)
+        Nothing -> do
+            status badRequest400
+            text (TL.pack $ show UnauthorizedSignIn)
+    else do
+      status badRequest400
+      text (TL.pack $ show 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
     Nothing ->
-      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 UnauthorizedSignIn)
+      return False
+    Just token -> do
+      liftIO . runDb . fmap isJust $ getUserFromToken token
+
+redirectError :: Text -> ActionM ()
+redirectError msg =
+  redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
-- 
cgit v1.2.3