Don't use persona anymore, use email token to sign in

4 files changed, 119 insertions, 7 deletions

diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index a98e69a..58160c3 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -44,6 +44,7 @@ SignIn
   token Text
   creation UTCTime
   email Text
+  isUsed Bool
   UniqSignInToken token
   deriving Show
 Job
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 34c9d71..4c0287b 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -8,16 +8,24 @@ data Key =
 
   SharedCost
 
-  -- Mail
+  -- Email
 
   | NoReplyMail
 
   -- Sign
 
+  | Email
   | SignIn
+  | SendEmailFail
   | InvalidEmail
   | UnauthorizedSignIn
-  | ErrorSignIn
+  | EnterValidEmail
+  | SignInUsed
+  | SignInExpired
+  | SignInInvalid
+  | SignInMailTitle
+  | SignInMail
+  | SignInEmailSent
 
   -- Dates
 
@@ -63,4 +71,10 @@ data Key =
   | Undo
   | NewIncome
 
+  -- Http error
+
+  | Timeout
+  | NetworkError
+  | UnexpectedPayload
+
   deriving (Enum, Bounded, Show)
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index 7ca6483..d34f3d7 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -22,7 +22,7 @@ m l SharedCost =
     English -> "Shared Cost"
     French  -> "Partage des frais"
 
--- Mail
+-- Email
 
 m l NoReplyMail =
   case l of
@@ -31,6 +31,11 @@ m l NoReplyMail =
 
 -- Sign in
 
+m l Email =
+  case l of
+    English -> "Email"
+    French -> "Courriel"
+
 m l SignIn =
   case l of
     English -> "Sign in"
@@ -46,10 +51,70 @@ m l UnauthorizedSignIn =
     English -> "You are not authorized to sign in."
     French  -> "Tu n'es pas autorisé à te connecter."
 
-m l ErrorSignIn =
+m l SendEmailFail =
+  case l of
+    English -> "You are authorized to sign in, but we failed to send you the sign up email."
+    French  -> "Tu es autorisé à te connecter, mais nous n'avons pas pu t'envoyer le courriel de connexion."
+
+m l EnterValidEmail =
+  case l of
+    English -> "Please enter a valid email address."
+    French  -> "Ton courriel n'est pas valide."
+
+m l SignInUsed =
+  case l of
+    English -> "You already used this link, please sign in again."
+    French  -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau."
+
+m l SignInExpired =
+  case l of
+    English -> "The link expired, please sign in again."
+    French  -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau."
+
+m l SignInInvalid =
+  case l of
+    English -> "The link is invalid, please sign in again."
+    French  -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau."
+
+m l SignInMailTitle =
+  case l of
+    English -> T.concat ["Sign in to ", m l SharedCost]
+    French  -> T.concat ["Connexion à ", m l SharedCost]
+
+m l SignInMail =
+  T.intercalate
+    "\n"
+    ( case l of
+        English ->
+          [ "Hi {1},"
+          , ""
+          , T.concat
+              [ "Click to the following link in order to sign in to Shared Cost:"
+              , m l SharedCost
+              , ":"
+              ]
+          , "{2}"
+          , ""
+          , "See you soon!"
+          ]
+        French  ->
+          [ "Salut {1},"
+          , ""
+          , T.concat
+              [ "Clique sur le lien suivant pour te connecter à "
+              , m l SharedCost
+              , ":"
+              ]
+          , "{2}"
+          , ""
+          , "À très vite !"
+          ]
+    )
+
+m l SignInEmailSent =
   case l of
-    English -> "An error occured, please retry later."
-    French  -> "Une erreur est survenue, veuillez réessayer ultérieurement."
+    English -> "We sent you an email with a connexion link."
+    French  -> "Nous t'avons envoyé un courriel avec un lien pour te connecter."
 
 -- Date
 
@@ -219,3 +284,20 @@ m l NewIncome =
   case l of
     English -> "New income"
     French  -> "Nouveau revenu"
+
+-- Http error
+
+m l Timeout =
+  case l of
+    English -> "Timeout server error"
+    French  -> "Le serveur met trop de temps à répondre"
+
+m l NetworkError =
+  case l of
+    English -> "Network can not be reached"
+    French  -> "Le serveur n'est pas accessible"
+
+m l UnexpectedPayload =
+  case l of
+    English -> "Unexpected payload server error"
+    French  -> "Contenu inattendu du en provenance du serveur"
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
index b475fdb..117b8b5 100644
--- a/src/server/Model/SignIn.hs
+++ b/src/server/Model/SignIn.hs
@@ -1,6 +1,8 @@
 module Model.SignIn
   ( createSignInToken
   , getSignInToken
+  , signInTokenToUsed
+  , isLastValidToken
   ) where
 
 import Data.Text (Text)
@@ -17,9 +19,22 @@ createSignInToken :: Text -> Persist Text
 createSignInToken email = do
   now <- liftIO getCurrentTime
   token <- liftIO generateUUID
-  _ <- insert $ SignIn token now email
+  _ <- insert $ SignIn token now email False
   return token
 
 getSignInToken :: Text -> Persist (Maybe (Entity SignIn))
 getSignInToken token =
   selectFirst [SignInToken ==. 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 ]