aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Config.hs2
-rw-r--r--src/server/Controller/SignIn.hs84
-rw-r--r--src/server/Design/Header.hs2
-rw-r--r--src/server/Design/SignIn.hs20
-rw-r--r--src/server/Main.hs12
-rw-r--r--src/server/Model/Database.hs1
-rw-r--r--src/server/Model/Message/Key.hs6
-rw-r--r--src/server/Model/Message/Translations.hs26
-rw-r--r--src/server/Model/SignIn.hs17
-rw-r--r--src/server/Persona.hs42
-rw-r--r--src/server/Secure.hs7
-rw-r--r--src/server/View/Page.hs4
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" $ ""
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 17:39:12 +0000