Using persona to validate emails

12 files changed, 71 insertions, 152 deletions

diff --git a/src/server/Config.hs b/src/server/Config.hs
index bd7f325..37f57ec 100644
--- a/src/server/Config.hs
+++ b/src/server/Config.hs
@@ -18,7 +18,6 @@ import Control.Arrow (left)
 data Config = Config
   { hostname :: Text
   , port :: Int
-  , signInExpirationMn :: Int
   , currency :: Text
   } deriving (Read, Eq, Show)
 
@@ -29,6 +28,5 @@ 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/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)
diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs
index 7b82577..9f83778 100644
--- a/src/server/Design/Header.hs
+++ b/src/server/Design/Header.hs
@@ -25,7 +25,7 @@ headerDesign =
       marginBottom blockMarginBottom
       paddingLeft sidePercent
 
-    button # ".signOut" ? do
+    button # ".icon" ? do
       let iconHeight = 50
       let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2)
       position absolute
diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs
index 6bacc3a..7aff720 100644
--- a/src/server/Design/SignIn.hs
+++ b/src/server/Design/SignIn.hs
@@ -15,26 +15,6 @@ signInDesign =
 
   ".signIn" ? do
 
-    opacityAnimation
-
-    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
-        defaultButton C.red C.white (px inputHeight)
-        display block
-        width (pct 100)
-
     ".result" ? do
       marginTop (px 40)
       textAlign (alignSide sideCenter)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 3d61481..3539120 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -8,7 +8,7 @@ import Control.Concurrent (forkIO)
 import MonthlyPaymentJob (monthlyPaymentJobListener)
 
 import Data.Text (Text)
-import qualified Data.Text.IO as TIO
+import qualified Data.Text.IO as T
 
 import Controller.Index
 import Controller.SignIn
@@ -28,7 +28,7 @@ main = do
   eitherConfig <- Config.getConfig "config.txt"
   case eitherConfig of
     Left errorMessage ->
-      TIO.putStrLn errorMessage
+      T.putStrLn errorMessage
     Right config -> do
       scotty (Config.port config) $ do
         middleware $
@@ -40,12 +40,8 @@ main = do
         -- SignIn
 
         post "/signIn" $ do
-          login <- param "login" :: ActionM Text
-          signIn config login
-
-        get "/validateSignIn" $ do
-          token <- param "token" :: ActionM Text
-          validateSignIn config token
+          assertion <- param "assertion" :: ActionM Text
+          signIn config assertion
 
         -- Users
 
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 8d1da25..67cc8b3 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -44,7 +44,6 @@ 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 e9f8ef6..7f49ae7 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -12,12 +12,8 @@ data Key =
 
   | SharedCost
   | SignIn
-  | SendEmailFail
+  | InvalidEmail
   | Unauthorized
-  | EnterValidEmail
-  | SignInUsed
-  | SignInExpired
-  | SignInInvalid
   | SignInMailTitle
   | SignInMail
   | SignInEmailSent
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index a2e9a30..29b21ea 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -34,36 +34,16 @@ m l SignIn =
     English -> "Sign in"
     French  -> "Connexion"
 
-m l SendEmailFail =
+m l InvalidEmail =
   case l of
-    English -> "Sorry, we failed to send you the sign up email."
-    French  -> "Désolé, nous n'avons pas pu t'envoyer le courriel de connexion."
+    English -> "Your email is not valid."
+    French  -> "Votre courriel n'est pas valide."
 
 m l Unauthorized =
   case l of
     English -> "You are not authorized to sign in."
     French  -> "Tu n'es pas autorisé à te connecter."
 
-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]
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
index 117b8b5..b475fdb 100644
--- a/src/server/Model/SignIn.hs
+++ b/src/server/Model/SignIn.hs
@@ -1,8 +1,6 @@
 module Model.SignIn
   ( createSignInToken
   , getSignInToken
-  , signInTokenToUsed
-  , isLastValidToken
   ) where
 
 import Data.Text (Text)
@@ -19,22 +17,9 @@ createSignInToken :: Text -> Persist Text
 createSignInToken email = do
   now <- liftIO getCurrentTime
   token <- liftIO generateUUID
-  _ <- insert $ SignIn token now email False
+  _ <- insert $ SignIn token now email
   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
new file mode 100644
index 0000000..8055e8b
--- /dev/null
+++ b/src/server/Persona.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Persona
+  ( verifyEmail
+  ) where
+
+import Control.Monad (guard)
+
+import Network.HTTP.Conduit
+
+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 $
+          [ ("assertion", encodeUtf8 $ assertion)
+          , ("audience", encodeUtf8 $ hostname config)
+          ]
+
+  manager <- newManager tlsManagerSettings
+  response <- httpLbs request manager
+
+  return . parseEmail . decodeUtf8 . toStrict . responseBody $ response
+
+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"
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 192fa10..7b6e6de 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -12,7 +12,7 @@ import Network.HTTP.Types.Status (forbidden403)
 import Database.Persist (Entity, entityVal)
 
 import Model.User (getUser)
-import Model.SignIn (getSignInToken, isLastValidToken)
+import Model.SignIn (getSignInToken)
 import Model.Database
 
 import Control.Monad.IO.Class (liftIO)
@@ -44,9 +44,6 @@ getUserFromToken token = do
   mbSignIn <- fmap entityVal <$> getSignInToken token
   case mbSignIn of
     Just signIn -> do
-      isValid <- isLastValidToken signIn
-      if isValid
-        then getUser (signInEmail signIn)
-        else return Nothing
+      getUser (signInEmail signIn)
     Nothing ->
       return Nothing
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index 2865337..7310fbb 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -26,7 +26,9 @@ page config =
   renderHtml . docTypeHtml $ do
     H.head $ do
       meta ! charset "UTF-8"
+      meta ! httpEquiv "X-UA-Compatible" ! content "IE=Edge" -- IE8+ only is valid to use with persona
       H.title (toHtml $ getMessage SharedCost)
+      script ! src "https://login.persona.org/include.js" $ ""
       script ! src "javascripts/client.js" $ ""
       script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations
       script ! A.id "config" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ config
@@ -35,4 +37,4 @@ page config =
       link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"
       H.style $ toHtml globalDesign
     body $ do
-      script ! src "javascripts/elmLauncher.js" $ ""
+      script ! src "javascripts/main.js" $ ""