From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- server/src/Controller/Index.hs | 128 ++++++++++++------------------------- server/src/Main.hs | 8 +-- server/src/Model/HashedPassword.hs | 27 ++++++++ server/src/Model/SignIn.hs | 60 +---------------- server/src/Persistence/User.hs | 48 ++++++++++++-- server/src/Secure.hs | 27 ++------ server/src/Validation/SignIn.hs | 16 +++++ server/src/View/Mail/SignIn.hs | 21 ------ server/src/View/Page.hs | 9 +-- 9 files changed, 145 insertions(+), 199 deletions(-) create mode 100644 server/src/Model/HashedPassword.hs create mode 100644 server/src/Validation/SignIn.hs delete mode 100644 server/src/View/Mail/SignIn.hs (limited to 'server/src') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 3788685..4f4ae77 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,120 +1,76 @@ module Controller.Index ( get - , askSignIn - , trySignIn + , signIn , signOut ) where import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as Json import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status -import Prelude hiding (error) +import Prelude hiding (error, init) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), Init (..), - InitResult (..), SignInForm (..), +import Common.Model (Init (..), SignInForm (..), User (..)) -import Common.Msg (Key) import qualified Common.Msg as Msg -import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession +import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn +import Model.SignIn (SignIn (..)) import qualified Persistence.User as UserPersistence -import qualified Secure -import qualified SendMail -import qualified View.Mail.SignIn as SignIn +import qualified Validation.SignIn as SignInValidation import View.Page (page) get :: Conf -> ActionM () get conf = do - initResult <- do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of + init <- do + mbToken <- LoginSession.get + case mbToken of Nothing -> - return InitEmpty - Just user -> do - users <- liftIO . Query.run $ UserPersistence.list - return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) - S.html $ page initResult + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init -askSignIn :: Conf -> SignInForm -> ActionM () -askSignIn conf form = +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = case SignInValidation.signIn form of - Nothing -> - textKey Status.badRequest400 Msg.SignIn_EmailInvalid - Just (Email email) -> do - maybeUser <- liftIO . Query.run $ UserPersistence.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "/api/signIn/", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized - where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init -trySignIn :: Conf -> Text -> ActionM () -trySignIn conf token = do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - S.html $ page (InitError $ Msg.get errorKey) - Right _ -> - S.redirect "/" - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of Nothing -> - return . Left $ Msg.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Msg.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Msg.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - UserPersistence.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Msg.Secure_Unauthorized - Just user -> Right user + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) Nothing -> return Nothing - Just token -> do - liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Main.hs b/server/src/Main.hs index 0b80de0..324557e 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -28,12 +28,8 @@ main = do S.middleware . staticPolicy $ noDots >-> addBase "public" - S.post "/api/askSignIn" $ - S.jsonData >>= Index.askSignIn conf - - S.get "/api/signIn/:signInToken" $ do - signInToken <- S.param "signInToken" - Index.trySignIn conf signInToken + S.post "/api/signIn" $ + S.jsonData >>= Index.signIn conf S.post "/api/signOut" $ Index.signOut conf diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs new file mode 100644 index 0000000..c71e372 --- /dev/null +++ b/server/src/Model/HashedPassword.hs @@ -0,0 +1,27 @@ +module Model.HashedPassword + ( hash + , check + , HashedPassword(..) + ) where + +import qualified Crypto.BCrypt as BCrypt +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Common.Model.Password (Password (..)) + +newtype HashedPassword = HashedPassword Text deriving (Show) + +hash :: Password -> IO (Maybe HashedPassword) +hash (Password p) = do + hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p) + case hashed of + Nothing -> + return Nothing + + Just h -> + return . Just . HashedPassword . TE.decodeUtf8 $ h + +check :: Password -> HashedPassword -> Bool +check (Password p) (HashedPassword h) = + BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p) diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index bcdce61..a217bae 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -1,64 +1,10 @@ module Model.SignIn ( SignIn(..) - , createSignInToken - , getSignIn - , signInTokenToUsed - , isLastTokenValid ) where -import Data.Int (Int64) -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Model.Query (Query (Query)) -import Model.UUID (generateUUID) - -type SignInId = Int64 +import Common.Model (Email, Password) data SignIn = SignIn - { id :: SignInId - , token :: Text - , creation :: UTCTime - , email :: Text - , isUsed :: Bool + { _signIn_email :: Email + , _signIn_password :: Password } deriving Show - -instance FromRow SignIn where - fromRow = SignIn <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -createSignInToken :: Text -> Query Text -createSignInToken signInEmail = - Query (\conn -> do - now <- getCurrentTime - signInToken <- generateUUID - SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) - return signInToken - ) - -getSignIn :: Text -> Query (Maybe SignIn) -getSignIn signInToken = - Query (\conn -> do - Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) - ) - -signInTokenToUsed :: SignInId -> Query () -signInTokenToUsed tokenId = - Query (\conn -> - SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) - ) - -isLastTokenValid :: SignIn -> Query Bool -isLastTokenValid signIn = - Query (\conn -> do - [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) - return . maybe False (== (token signIn)) $ lastToken - ) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 89eb57d..12145ac 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -1,17 +1,21 @@ module Persistence.User ( list , get + , checkPassword + , createSignInToken ) where import qualified Data.Maybe as Maybe import Data.Text (Text) import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) -import Common.Model (User (..)) +import Common.Model (Email (..), Password (..), User (..)) +import Model.HashedPassword (HashedPassword (..)) +import qualified Model.HashedPassword as HashedPassword import Model.Query (Query (Query)) +import qualified Model.UUID as UUID newtype Row = Row User @@ -26,15 +30,49 @@ list :: Query [User] list = Query (\conn -> do map (\(Row u) -> u) <$> - SQLite.query_ conn "SELECT * from user ORDER BY creation DESC" + SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC" ) get :: Text -> Query (Maybe User) -get email = +get token = Query (\conn -> do fmap (\(Row u) -> u) . Maybe.listToMaybe <$> SQLite.queryNamed conn - "SELECT * FROM user WHERE email = :email LIMIT 1" + "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1" + [ ":sign_in_token" := token ] + ) + +data HashedPasswordRow = HashedPasswordRow HashedPassword + +instance FromRow HashedPasswordRow where + fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field) + +checkPassword :: Email -> Password -> Query Bool +checkPassword (Email email) password = + Query (\conn -> do + hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT password FROM user WHERE email = :email LIMIT 1" [ ":email" := email ] + case hashedPassword of + Just h -> + return (HashedPassword.check password h) + + Nothing -> + return False + ) + +createSignInToken :: Email -> Query Text +createSignInToken (Email email) = + Query (\conn -> do + token <- UUID.generateUUID + SQLite.executeNamed + conn + "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email" + [ ":sign_in_token" := token + , ":email" := email + ] + return token ) diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 4fb2333..a30941f 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -1,21 +1,17 @@ module Secure ( loggedAction - , getUserFromToken ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) +import qualified Data.Text.Lazy as TL +import qualified Network.HTTP.Types.Status as HTTP import Web.Scotty import Common.Model (User) import qualified Common.Msg as Msg import qualified LoginSession -import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn import qualified Persistence.User as UserPersistence loggedAction :: (User -> ActionM ()) -> ActionM () @@ -23,22 +19,13 @@ loggedAction action = do maybeToken <- LoginSession.get case maybeToken of Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token + maybeUser <- liftIO . Query.run . UserPersistence.get $ token case maybeUser of Just user -> action user Nothing -> do - status forbidden403 - html . fromStrict . Msg.get $ Msg.Secure_Unauthorized + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized Nothing -> do - status forbidden403 - html . fromStrict . Msg.get $ Msg.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - UserPersistence.get (SignIn.email signIn) - Nothing -> - return Nothing + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs new file mode 100644 index 0000000..dc86122 --- /dev/null +++ b/server/src/Validation/SignIn.hs @@ -0,0 +1,16 @@ +module Validation.SignIn + ( signIn + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model (SignInForm (..)) +import qualified Common.Validation.SignIn as SignInValidation +import Model.SignIn (SignIn (..)) + +signIn :: SignInForm -> Validation Text SignIn +signIn form = + SignIn + <$> SignInValidation.email (_signInForm_email form) + <*> SignInValidation.password (_signInForm_password form) diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs deleted file mode 100644 index 3c5469f..0000000 --- a/server/src/View/Mail/SignIn.hs +++ /dev/null @@ -1,21 +0,0 @@ -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import Common.Model (User (..)) -import qualified Common.Msg as Msg - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Msg.get Msg.SignIn_MailTitle - , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url) - } diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index f47c544..4ada5f7 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -6,6 +6,7 @@ import Data.Aeson (encode) import qualified Data.Aeson.Types as Json import Data.Text.Internal.Lazy (Text) import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (init) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -14,20 +15,20 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A -import Common.Model (InitResult) +import Common.Model (Init) import qualified Common.Msg as Msg import Design.Global (globalDesign) -page :: InitResult -> Text -page initResult = +page :: Maybe Init -> Text +page init = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" H.title (toHtml $ Msg.get Msg.App_Title) script ! src "/javascript/main.js" $ "" - jsonScript "init" initResult + jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign -- cgit v1.2.3