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

11 files changed, 230 insertions, 90 deletions

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"