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/client/elm/Main.elm                      | 11 +---
 src/client/elm/Model/Action/SignInAction.elm |  4 +-
 src/client/elm/Model/View/SignInView.elm     | 10 ++--
 src/client/elm/Persona.elm                   | 11 ----
 src/client/elm/Server.elm                    |  4 +-
 src/client/elm/Update.elm                    | 11 ++--
 src/client/elm/Update/SignIn.elm             | 18 +++++-
 src/client/elm/Utils/Http.elm                | 21 +++++--
 src/client/elm/View/SignIn.elm               | 54 ++++++++++-------
 src/client/js/main.js                        | 20 +++----
 src/server/Config.hs                         |  2 +
 src/server/Controller/Payment.hs             |  8 ++-
 src/server/Controller/SignIn.hs              | 89 ++++++++++++++++++++++-----
 src/server/Design/SignIn.hs                  | 34 +++++++----
 src/server/Json.hs                           |  8 +--
 src/server/Main.hs                           |  8 ++-
 src/server/Model/Database.hs                 |  1 +
 src/server/Model/Message/Key.hs              | 18 +++++-
 src/server/Model/Message/Translations.hs     | 90 ++++++++++++++++++++++++++--
 src/server/Model/SignIn.hs                   | 17 +++++-
 src/server/Persona.hs                        | 45 --------------
 21 files changed, 322 insertions(+), 162 deletions(-)
 delete mode 100644 src/client/elm/Persona.elm
 delete mode 100644 src/server/Persona.hs

(limited to 'src')

diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm
index 7d13376..b4b440b 100644
--- a/src/client/elm/Main.elm
+++ b/src/client/elm/Main.elm
@@ -18,8 +18,6 @@ import Update exposing (update)
 
 import View exposing (view)
 
-import Persona as Persona exposing (operations)
-
 import Server
 
 main : Signal Html
@@ -36,10 +34,7 @@ app = StartApp.start
       )
   , view = view
   , update = update
-  , inputs =
-      [ Signal.map UpdateTime (Time.every 1000)
-      , Signal.map SignIn validateSignIn
-      ]
+  , inputs = [ Signal.map UpdateTime (Time.every 1000) ]
   }
 
 port tasks : Signal (Task.Task Never ())
@@ -50,9 +45,7 @@ port tasks = app.tasks
 port initialTime : Time
 port translations : String
 port config : String
-port validateSignIn : Signal String
 
 -- Output ports
 
-port askSignIn : Signal String
-port askSignIn = Signal.map toString operations.signal
+port signInError : Maybe String
diff --git a/src/client/elm/Model/Action/SignInAction.elm b/src/client/elm/Model/Action/SignInAction.elm
index eaa9f8b..619dbda 100644
--- a/src/client/elm/Model/Action/SignInAction.elm
+++ b/src/client/elm/Model/Action/SignInAction.elm
@@ -3,5 +3,7 @@ module Model.Action.SignInAction
   ) where
 
 type SignInAction =
-  WaitingServer
+  UpdateLogin String
+  | WaitingServer
+  | ValidLogin String
   | ErrorLogin String
diff --git a/src/client/elm/Model/View/SignInView.elm b/src/client/elm/Model/View/SignInView.elm
index a950867..0d69445 100644
--- a/src/client/elm/Model/View/SignInView.elm
+++ b/src/client/elm/Model/View/SignInView.elm
@@ -4,12 +4,14 @@ module Model.View.SignInView
   ) where
 
 type alias SignInView =
-  { waitingServer : Bool
-  , error : Maybe String
+  { login : String
+  , waitingServer : Bool
+  , result : Maybe (Result String String)
   }
 
 initSignInView : SignInView
 initSignInView =
-  { waitingServer = False
-  , error = Nothing
+  { login = ""
+  , waitingServer = False
+  , result = Nothing
   }
diff --git a/src/client/elm/Persona.elm b/src/client/elm/Persona.elm
deleted file mode 100644
index d5e1d6a..0000000
--- a/src/client/elm/Persona.elm
+++ /dev/null
@@ -1,11 +0,0 @@
-module Persona
-  ( Operation(..)
-  , operations
-  ) where
-
-type Operation =
-  NoOp
-  | SignIn
-
-operations : Signal.Mailbox Operation
-operations = Signal.mailbox NoOp
diff --git a/src/client/elm/Server.elm b/src/client/elm/Server.elm
index 7b03a98..9478f2a 100644
--- a/src/client/elm/Server.elm
+++ b/src/client/elm/Server.elm
@@ -31,8 +31,8 @@ init =
     `Task.andMap` (Http.get payersDecoder "/payers")
 
 signIn : String -> Task Http.Error Init
-signIn assertion =
-  post ("/signIn?assertion=" ++ assertion)
+signIn email =
+  post ("/signIn?email=" ++ email)
     |> flip Task.andThen (always init)
 
 addPayment : String -> String -> PaymentFrequency -> Task Http.Error PaymentId
diff --git a/src/client/elm/Update.elm b/src/client/elm/Update.elm
index bfc3bf6..948ab1f 100644
--- a/src/client/elm/Update.elm
+++ b/src/client/elm/Update.elm
@@ -20,6 +20,8 @@ import Model.View.LoggedInView exposing (..)
 import Update.LoggedIn exposing (updateLoggedIn)
 import Update.SignIn exposing (updateSignIn)
 
+import Utils.Http exposing (errorKey)
+
 update : Action -> Model -> (Model, Effects Action)
 update action model =
   case action of
@@ -27,12 +29,13 @@ update action model =
     NoOp ->
       (model, Effects.none)
 
-    SignIn assertion ->
+    SignIn email ->
       ( applySignIn model (SignInAction.WaitingServer)
-      , Server.signIn assertion
+      , Server.signIn email
           |> Task.map GoLoggedInView
-          |> flip Task.onError (\_ ->
-               Task.succeed (UpdateSignIn (SignInAction.ErrorLogin (getMessage "ErrorSignIn" model.translations)))
+          |> flip Task.onError (\error ->
+               let errorMessage = getMessage (errorKey error) model.translations
+               in  Task.succeed (UpdateSignIn (SignInAction.ErrorLogin errorMessage))
              )
           |> Effects.task
       )
diff --git a/src/client/elm/Update/SignIn.elm b/src/client/elm/Update/SignIn.elm
index 94963c8..f55ce6d 100644
--- a/src/client/elm/Update/SignIn.elm
+++ b/src/client/elm/Update/SignIn.elm
@@ -2,16 +2,28 @@ module Update.SignIn
   ( updateSignIn
   ) where
 
-import Model.Action.SignInAction exposing (..)
 import Model.View.SignInView exposing (..)
+import Model.Action.SignInAction exposing (..)
 
 updateSignIn : SignInAction -> SignInView -> SignInView
 updateSignIn action signInView =
   case action of
+    UpdateLogin login ->
+      { signInView |
+      login = login
+      }
     WaitingServer ->
-      { signInView | waitingServer = True }
+      { signInView
+      | waitingServer = True
+      }
+    ValidLogin message ->
+      { signInView
+      | login = ""
+      , result = Just (Ok message)
+      , waitingServer = False
+      }
     ErrorLogin message ->
       { signInView
-      | error = Just message
+      | result = Just (Err message)
       , waitingServer = False
       }
diff --git a/src/client/elm/Utils/Http.elm b/src/client/elm/Utils/Http.elm
index 2cf1294..bd6e2ac 100644
--- a/src/client/elm/Utils/Http.elm
+++ b/src/client/elm/Utils/Http.elm
@@ -1,6 +1,7 @@
 module Utils.Http
   ( post
   , decodeHttpValue
+  , errorKey
   ) where
 
 import Http exposing (..)
@@ -18,6 +19,12 @@ post url =
     |> mapError promoteError
     |> flip Task.andThen handleResponse
 
+promoteError : RawError -> Error
+promoteError rawError =
+  case rawError of
+    RawTimeout -> Timeout
+    RawNetworkError -> NetworkError
+
 handleResponse : Response -> Task Error Value
 handleResponse response =
   if 200 <= response.status && response.status < 300
@@ -30,12 +37,6 @@ responseString value =
     Text str -> str
     _ -> ""
 
-promoteError : RawError -> Error
-promoteError rawError =
-  case rawError of
-    RawTimeout -> Timeout
-    RawNetworkError -> NetworkError
-
 decodeHttpValue : Decoder a -> Value -> Task Error a
 decodeHttpValue decoder value =
   case value of
@@ -45,3 +46,11 @@ decodeHttpValue decoder value =
         Err msg -> fail (UnexpectedPayload msg)
     _ ->
       fail (UnexpectedPayload "Response body is a blob, expecting a string.")
+
+errorKey : Error -> String
+errorKey error =
+  case error of
+    Timeout -> "Timeout"
+    NetworkError -> "NetworkError"
+    UnexpectedPayload _ -> "UnexpectedPayload"
+    BadResponse _ key -> key
diff --git a/src/client/elm/View/SignIn.elm b/src/client/elm/View/SignIn.elm
index c21c16c..908ab62 100644
--- a/src/client/elm/View/SignIn.elm
+++ b/src/client/elm/View/SignIn.elm
@@ -2,12 +2,14 @@ module View.SignIn
   ( renderSignIn
   ) where
 
-import Json.Decode as Json
-import Signal exposing (Address)
-
 import Html as H exposing (..)
 import Html.Attributes exposing (..)
 import Html.Events exposing (..)
+import Signal exposing (Address)
+import Json.Decode as Json
+
+import Update exposing (..)
+import Update.SignIn exposing (..)
 
 import Model exposing (Model)
 import Model.Action exposing (..)
@@ -16,33 +18,43 @@ import Model.View.SignInView exposing (..)
 import Model.Translations exposing (getMessage)
 
 import View.Events exposing (onSubmitPrevDefault)
-import View.Icon exposing (..)
-
-import Persona exposing (operations)
+import View.Icon exposing (renderSpinIcon)
 
 renderSignIn : Address Action -> Model -> SignInView -> Html
 renderSignIn address model signInView =
   div
     [ class "signIn" ]
-    [ button
-        ( if signInView.waitingServer
-            then [ class "waitingServer" ]
-            else [ onClick operations.address Persona.SignIn ]
-        )
-        [ span [] [ text (getMessage "SignIn" model.translations) ]
-        , if signInView.waitingServer
-            then renderSpinIcon
-            else renderIcon "power-off"
+    [ H.form
+        [ onSubmitPrevDefault address (SignIn signInView.login) ]
+        [ input
+            [ value signInView.login
+            , on "input" targetValue (Signal.message address << UpdateSignIn << UpdateLogin)
+            ]
+            []
+        , button
+            []
+            [ if signInView.waitingServer
+                then renderSpinIcon
+                else text (getMessage "SignIn" model.translations)
+            ]
         ]
-    , signInResult model signInView
+    , div
+        [ class "result" ]
+        [ signInResult model signInView ]
     ]
 
 signInResult : Model -> SignInView -> Html
 signInResult model signInView =
-  case signInView.error of
-    Just error ->
-      div
-        [ class "error" ]
-        [ text error ]
+  case signInView.result of
+    Just result ->
+      case result of
+        Ok login ->
+          div
+            [ class "success" ]
+            [ text (getMessage "SignInEmailSent" model.translations) ]
+        Err error ->
+          div
+            [ class "error" ]
+            [ text error ]
     Nothing ->
       text ""
diff --git a/src/client/js/main.js b/src/client/js/main.js
index 2704746..bdcb479 100644
--- a/src/client/js/main.js
+++ b/src/client/js/main.js
@@ -1,15 +1,13 @@
-var app = Elm.fullscreen(Elm.Main, {
+Elm.fullscreen(Elm.Main, {
+  signInError: getParameterByName('signInError'),
   initialTime: new Date().getTime(),
   translations: document.getElementById('messages').innerHTML,
-  config: document.getElementById('config').innerHTML,
-  validateSignIn: ""
+  config: document.getElementById('config').innerHTML
 });
 
-app.ports.askSignIn.subscribe(function() {
-  navigator.id.watch({
-    loggedInUser: null,
-    onlogin: function(assertion) { app.ports.validateSignIn.send(assertion); },
-    onlogout: function() {}
-  });
-  navigator.id.request();
-});
+function getParameterByName(name) {
+  name = name.replace(/[\[]/, "\\[").replace(/[\]]/, "\\]");
+  var regex = new RegExp("[\\?&]" + name + "=([^&#]*)"),
+      results = regex.exec(location.search);
+  return results && decodeURIComponent(results[1].replace(/\+/g, " "));
+}
diff --git a/src/server/Config.hs b/src/server/Config.hs
index 37f57ec..bd7f325 100644
--- a/src/server/Config.hs
+++ b/src/server/Config.hs
@@ -18,6 +18,7 @@ import Control.Arrow (left)
 data Config = Config
   { hostname :: Text
   , port :: Int
+  , signInExpirationMn :: Int
   , currency :: Text
   } deriving (Read, Eq, Show)
 
@@ -28,5 +29,6 @@ getConfig filePath =
     Config <$>
       (T.pack <$> get cp "DEFAULT" "hostname") <*>
       (get cp "DEFAULT" "port") <*>
+      (get cp "DEFAULT" "sign-in-expiration-mn") <*>
       (T.pack <$> get cp "DEFAULT" "currency")
   )
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index e94b300..432603b 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -18,11 +18,12 @@ 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.Aeson.Types as Json
 
 import qualified Secure
 
-import Json (jsonObject, jsonError)
+import Json (jsonObject)
 
 import Model.Database
 import qualified Model.Payment as P
@@ -62,8 +63,9 @@ deletePayment paymentId =
     if deleted
       then
         status ok200
-      else
-        jsonError (getMessage PaymentNotDeleted)
+      else do
+        status badRequest400
+        text . TL.pack . show $ PaymentNotDeleted
   )
 
 getPaymentsCount :: ActionM ()
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]
diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs
index a565ee4..d2487f1 100644
--- a/src/server/Design/SignIn.hs
+++ b/src/server/Design/SignIn.hs
@@ -15,14 +15,28 @@ signInDesign =
 
   ".signIn" ? do
 
-    button ? do
-      display block
-      margin (em 5) auto (em 2) auto
-      iconButton C.blue C.white (em 2.5) focusLighten
-      fontSize (em 1.5)
-      position relative
-      ".waitingServer" & ("cursor" -: "not-allowed")
-
-    ".error" ? do
+    form ? do
+      let inputHeight = 50
+      width (px 500)
+      marginTop (px 100)
+      marginLeft auto
+      marginRight auto
+
+      input ? do
+        defaultInput inputHeight
+        display block
+        width (pct 100)
+        marginBottom (px 10)
+
+      button ? do
+        iconButton C.blue C.white (px inputHeight) focusLighten
+        display block
+        width (pct 100)
+        fontSize (em 1.2)
+        ".waitingServer" & ("cursor" -: "not-allowed")
+
+    ".result" ? do
+      marginTop (px 40)
       textAlign (alignSide sideCenter)
-      color C.redError
+      ".success" ? color C.green
+      ".error" ? color C.redError
diff --git a/src/server/Json.hs b/src/server/Json.hs
index bd5ac3e..935a9cb 100644
--- a/src/server/Json.hs
+++ b/src/server/Json.hs
@@ -1,8 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Json
-  ( jsonError
-  , jsonObject
+  ( jsonObject
   ) where
 
 import Web.Scotty
@@ -13,10 +12,5 @@ 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/Main.hs b/src/server/Main.hs
index e5d8cca..3ce6e64 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -41,8 +41,12 @@ main = do
         -- SignIn
 
         post "/signIn" $ do
-          assertion <- param "assertion" :: ActionM Text
-          signIn config assertion
+          email <- param "email" :: ActionM Text
+          signIn config email
+
+        get "/validateSignIn" $ do
+          token <- param "token" :: ActionM Text
+          validateSignIn config token
 
         -- Users
 
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 ]
diff --git a/src/server/Persona.hs b/src/server/Persona.hs
deleted file mode 100644
index 267ee3b..0000000
--- a/src/server/Persona.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Persona
-  ( verifyEmail
-  ) where
-
-import Control.Monad (guard)
-
-import Network.HTTP.Conduit
-import Network.HTTP.Types.Status (ok200)
-
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.ByteString.Lazy (fromStrict, toStrict)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8)
-import Data.Aeson
-import Data.Aeson.Types (parseMaybe)
-
-import Config
-
-verifyEmail :: Config -> Text -> IO (Maybe Text)
-verifyEmail config assertion = do
-
-  initReq <- parseUrl "https://verifier.login.persona.org/verify"
-
-  let request =
-        (flip urlEncodedBody) (initReq { checkStatus = \_ _ _ -> Nothing }) $
-          [ ("assertion", encodeUtf8 $ assertion)
-          , ("audience", encodeUtf8 $ hostname config)
-          ]
-
-  manager <- newManager tlsManagerSettings
-  response <- httpLbs request manager
-
-  if responseStatus response == ok200
-    then return . parseEmail . decodeUtf8 . toStrict . responseBody $ response
-    else return Nothing
-
-parseEmail :: Text -> Maybe Text
-parseEmail payload = do
-  result <- decode . fromStrict . encodeUtf8 $ payload
-  flip parseMaybe result $ \obj -> do
-    status <- T.pack <$> obj .: "status"
-    guard (status == "okay")
-    obj .: "email"
-- 
cgit v1.2.3