aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/elm/Main.elm11
-rw-r--r--src/client/elm/Model/Action/SignInAction.elm4
-rw-r--r--src/client/elm/Model/View/SignInView.elm10
-rw-r--r--src/client/elm/Persona.elm11
-rw-r--r--src/client/elm/Server.elm4
-rw-r--r--src/client/elm/Update.elm11
-rw-r--r--src/client/elm/Update/SignIn.elm18
-rw-r--r--src/client/elm/Utils/Http.elm21
-rw-r--r--src/client/elm/View/SignIn.elm54
-rw-r--r--src/client/js/main.js20
-rw-r--r--src/server/Config.hs2
-rw-r--r--src/server/Controller/Payment.hs8
-rw-r--r--src/server/Controller/SignIn.hs89
-rw-r--r--src/server/Design/SignIn.hs34
-rw-r--r--src/server/Json.hs8
-rw-r--r--src/server/Main.hs8
-rw-r--r--src/server/Model/Database.hs1
-rw-r--r--src/server/Model/Message/Key.hs18
-rw-r--r--src/server/Model/Message/Translations.hs90
-rw-r--r--src/server/Model/SignIn.hs17
-rw-r--r--src/server/Persona.hs45
21 files changed, 322 insertions, 162 deletions
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:21:43 +0000