Verify users' email addresses when they attempt to sign-up

Lots of changes here:
- Add the GET /verify endpoint
- Email users a secret using MailGun
- Create a PendingAccounts table and record type
- Prefer do-notation for FromRow instances (and in general) instead of the <*>
  or a liftA2 style. Using instances using `<*>` makes the instances depend on
  the order in which the record's fields were defined. When combined with a
  "SELECT *", which returns the columns in whichever order the schema defines
  them (or depending on the DB implementation), produces runtime parse errors
  at best and silent errors at worst.
- Delete bill from accounts.csv to free up the wpcarro@gmail.com when testing
  the /verify route.
This commit is contained in:
William Carroll 2020-07-30 18:38:46 +01:00
parent 30838b8df7
commit dec8890190
7 changed files with 178 additions and 31 deletions

View file

@ -1,3 +1,2 @@
mimi,$2b$12$LynoGCNbe2RA1WWSiBEMVudJKs5dxnssY16rYmUyiwlSBIhHBOLbu,miriamwright@google.com,user,
bill,$2b$12$wzh1OyNsvrrGt4hI52Wkt.QDX0IdPKn5uuNSgO/9CWucxipt5wlMi,wpcarro@gmail.com,manager,
wpcarro,$2b$12$3wbi4xfQmksLsu6GOKTbj.5WHywESATnXB4R8FJ55RSRLy6X9xA7u,wpcarro@google.com,admin,
1 mimi $2b$12$LynoGCNbe2RA1WWSiBEMVudJKs5dxnssY16rYmUyiwlSBIhHBOLbu miriamwright@google.com user
bill $2b$12$wzh1OyNsvrrGt4hI52Wkt.QDX0IdPKn5uuNSgO/9CWucxipt5wlMi wpcarro@gmail.com manager
2 wpcarro $2b$12$3wbi4xfQmksLsu6GOKTbj.5WHywESATnXB4R8FJ55RSRLy6X9xA7u wpcarro@google.com admin

View file

@ -18,6 +18,10 @@ type API =
"accounts"
:> ReqBody '[JSON] T.CreateAccountRequest
:> Post '[JSON] NoContent
:<|> "verify"
:> QueryParam' '[Required] "username" Text
:> QueryParam' '[Required] "secret" Text
:> Get '[JSON] NoContent
-- accounts: Read
-- accounts: Update
-- accounts: Delete

View file

@ -1,12 +1,26 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
module Accounts where
--------------------------------------------------------------------------------
import Database.SQLite.Simple
import qualified PendingAccounts
import qualified Types as T
--------------------------------------------------------------------------------
-- | Delete the account in PendingAccounts and create on in Accounts.
transferFromPending :: FilePath -> T.PendingAccount -> IO ()
transferFromPending dbFile T.PendingAccount{..} = withConnection dbFile $
\conn -> withTransaction conn $ do
PendingAccounts.delete dbFile pendingAccountUsername
execute conn "INSERT INTO Accounts (username,password,email,role) VALUES (?,?,?,?)"
( pendingAccountUsername
, pendingAccountPassword
, pendingAccountEmail
, pendingAccountRole
)
-- | Create a new account in the Accounts table.
create :: FilePath -> T.Username -> T.ClearTextPassword -> T.Email -> T.Role -> IO ()
create dbFile username password email role = withConnection dbFile $ \conn -> do

View file

@ -17,6 +17,8 @@ import API
import Utils
import Web.Cookie
import qualified System.Random as Random
import qualified Email as Email
import qualified Crypto.KDF.BCrypt as BC
import qualified Data.Text.Encoding as TE
import qualified Data.UUID as UUID
@ -27,6 +29,7 @@ import qualified Auth as Auth
import qualified Trips as Trips
import qualified Sessions as Sessions
import qualified LoginAttempts as LoginAttempts
import qualified PendingAccounts as PendingAccounts
--------------------------------------------------------------------------------
err429 :: ServerError
@ -37,8 +40,25 @@ err429 = ServerError
, errHeaders = []
}
-- | Send an email to recipient, `to`, with a secret code.
sendVerifyEmail :: Text
-> T.Username
-> T.Email
-> T.RegistrationSecret
-> IO (Either Email.SendError Email.SendSuccess)
sendVerifyEmail apiKey (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do
Email.send apiKey subject (cs body) email
where
subject = "Please confirm your account"
-- TODO(wpcarro): Use a URL encoder
-- TODO(wpcarro): Use a dynamic domain and port number
body =
let secret = secretUUID |> UUID.toString in
"http://localhost:3000/verify?username=" ++ cs username ++ "&secret=" ++ secret
server :: T.Config -> Server API
server T.Config{..} = createAccount
:<|> verifyAccount
:<|> deleteAccount
:<|> listAccounts
:<|> createTrip
@ -54,14 +74,37 @@ server T.Config{..} = createAccount
-- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
createAccount :: T.CreateAccountRequest -> Handler NoContent
createAccount request = do
liftIO $ Accounts.create dbFile
(T.createAccountRequestUsername request)
(T.createAccountRequestPassword request)
(T.createAccountRequestEmail request)
(T.createAccountRequestRole request)
createAccount T.CreateAccountRequest{..} = do
secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO
liftIO $ PendingAccounts.create dbFile
secretUUID
createAccountRequestUsername
createAccountRequestPassword
createAccountRequestRole
createAccountRequestEmail
liftIO $ sendVerifyEmail mailgunAPIKey
createAccountRequestUsername
createAccountRequestEmail
secretUUID
pure NoContent
verifyAccount :: Text -> Text -> Handler NoContent
verifyAccount username secret = do
let mSecretUUID = T.RegistrationSecret <$> UUID.fromText secret in do
case mSecretUUID of
Nothing -> throwError err401 { errBody = "Invalid secret format" }
Just secretUUID -> do
mPendingAccount <- liftIO $ PendingAccounts.get dbFile (T.Username username)
case mPendingAccount of
Nothing ->
throwError err401 { errBody = "Either your secret or your username (or both) is invalid" }
Just pendingAccount@T.PendingAccount{..} ->
if pendingAccountSecret == secretUUID then do
liftIO $ Accounts.transferFromPending dbFile pendingAccount
pure NoContent
else
throwError err401 { errBody = "The secret you provided is invalid" }
deleteAccount :: T.SessionCookie -> Text -> Handler NoContent
deleteAccount cookie username = adminsOnly cookie $ do
liftIO $ Accounts.delete dbFile (T.Username username)

32
src/PendingAccounts.hs Normal file
View file

@ -0,0 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module PendingAccounts where
--------------------------------------------------------------------------------
import Database.SQLite.Simple
import qualified Types as T
--------------------------------------------------------------------------------
create :: FilePath
-> T.RegistrationSecret
-> T.Username
-> T.ClearTextPassword
-> T.Role
-> T.Email
-> IO ()
create dbFile secret username password role email = withConnection dbFile $ \conn -> do
hashed <- T.hashPassword password
execute conn "INSERT INTO PendingAccounts (secret,username,password,role,email) VALUES (?,?,?,?,?)"
(secret, username, hashed, role, email)
get :: FilePath -> T.Username -> IO (Maybe T.PendingAccount)
get dbFile username = withConnection dbFile $ \conn -> do
res <- query conn "SELECT * FROM PendingAccounts WHERE username = ?" (Only username)
case res of
[x] -> pure (Just x)
_ -> pure Nothing
delete :: FilePath -> T.Username -> IO ()
delete dbFile username = withConnection dbFile $ \conn ->
execute conn "DELETE FROM PendingAccounts WHERE username = ?" (Only username)

View file

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
--------------------------------------------------------------------------------
module Types where
@ -24,6 +25,7 @@ import qualified Data.Time.Clock as Clock
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as TE
import qualified Data.Maybe as M
import qualified Data.UUID as UUID
--------------------------------------------------------------------------------
@ -34,16 +36,17 @@ data Config = Config
} deriving (Eq, Show)
instance FromEnv Config where
fromEnv _ =
Config <$> env "MAILGUN_API_KEY"
<*> env "DB_FILE"
fromEnv _ = do
mailgunAPIKey <- env "MAILGUN_API_KEY"
dbFile <- env "DB_FILE"
pure Config {..}
-- TODO(wpcarro): Properly handle NULL for columns like profilePicture.
forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b
forNewtype wrapper field =
case fieldData field of
(SQLText x) -> Ok (wrapper x)
_ -> returnError ConversionFailed field ""
x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x)
newtype Username = Username Text
deriving (Eq, Show, Generic)
@ -67,7 +70,7 @@ instance FromField HashedPassword where
fromField field =
case fieldData field of
(SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok
_ -> returnError ConversionFailed field ""
x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x)
newtype ClearTextPassword = ClearTextPassword Text
deriving (Eq, Show, Generic)
@ -119,7 +122,7 @@ instance FromField Role where
(SQLText "user") -> Ok RegularUser
(SQLText "manager") -> Ok Manager
(SQLText "admin") -> Ok Admin
_ -> returnError ConversionFailed field ""
x -> returnError ConversionFailed field ("We expected user, manager, admin, but we received: " ++ show x)
-- TODO(wpcarro): Prefer Data.ByteString instead of Text
newtype ProfilePicture = ProfilePicture Text
@ -158,11 +161,13 @@ accountFields (Account { accountUsername
)
instance FromRow Account where
fromRow = Account <$> field
<*> field
<*> field
<*> field
<*> field
fromRow = do
accountUsername <- field
accountPassword <- field
accountEmail <- field
accountRole <- field
accountProfilePicture <- field
pure Account{..}
data Session = Session
{ username :: Username
@ -221,11 +226,13 @@ data Trip = Trip
} deriving (Eq, Show, Generic)
instance FromRow Trip where
fromRow = Trip <$> field
<*> field
<*> field
<*> field
<*> field
fromRow = do
tripUsername <- field
tripDestination <- field
tripStartDate <- field
tripEndDate <- field
tripComment <- field
pure Trip{..}
-- | The fields used as the Primary Key for a Trip entry.
data TripPK = TripPK
@ -370,9 +377,9 @@ instance FromField SessionUUID where
case fieldData field of
(SQLText x) ->
case UUID.fromText x of
Nothing -> returnError ConversionFailed field ""
Nothing -> returnError ConversionFailed field ("Could not convert to UUID: " ++ show x)
Just x -> Ok $ SessionUUID x
_ -> returnError ConversionFailed field ""
_ -> returnError ConversionFailed field "Expected SQLText for SessionUUID, but we received"
instance ToField SessionUUID where
toField (SessionUUID uuid) =
@ -385,9 +392,11 @@ data StoredSession = StoredSession
} deriving (Eq, Show, Generic)
instance FromRow StoredSession where
fromRow = StoredSession <$> field
<*> field
<*> field
fromRow = do
storedSessionUUID <- field
storedSessionUsername <- field
storedSessionTsCreated <- field
pure StoredSession {..}
data LoginAttempt = LoginAttempt
{ loginAttemptUsername :: Username
@ -395,7 +404,10 @@ data LoginAttempt = LoginAttempt
} deriving (Eq, Show)
instance FromRow LoginAttempt where
fromRow = LoginAttempt <$> field <*> field
fromRow = do
loginAttemptUsername <- field
loginAttemptNumAttempts <- field
pure LoginAttempt {..}
newtype SessionCookie = SessionCookie Cookies
@ -404,3 +416,36 @@ instance FromHttpApiData SessionCookie where
x |> parseCookies |> SessionCookie |> pure
parseQueryParam x =
x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure
newtype RegistrationSecret = RegistrationSecret UUID.UUID
deriving (Eq, Show)
instance FromField RegistrationSecret where
fromField field =
case fieldData field of
(SQLText x) ->
case UUID.fromText x of
Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x)
Just x -> Ok $ RegistrationSecret x
_ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect"
instance ToField RegistrationSecret where
toField (RegistrationSecret secretUUID) =
secretUUID |> UUID.toText |> SQLText
data PendingAccount = PendingAccount
{ pendingAccountSecret :: RegistrationSecret
, pendingAccountUsername :: Username
, pendingAccountPassword :: HashedPassword
, pendingAccountRole :: Role
, pendingAccountEmail :: Email
} deriving (Eq, Show)
instance FromRow PendingAccount where
fromRow = do
pendingAccountSecret <- field
pendingAccountUsername <- field
pendingAccountPassword <- field
pendingAccountRole <- field
pendingAccountEmail <- field
pure PendingAccount {..}

View file

@ -10,9 +10,9 @@ DROP TABLE IF EXISTS Accounts;
DROP TABLE IF EXISTS Trips;
DROP TABLE IF EXISTS Sessions;
DROP TABLE IF EXISTS LoginAttempts;
DROP TABLE IF EXISTS PendingAccounts;
CREATE TABLE Accounts (
-- TODO(wpcarro): Add CHECK(..) constraint
username TEXT CHECK(LENGTH(username) > 0) NOT NULL,
password TEXT CHECK(LENGTH(password) > 0) NOT NULL,
email TEXT CHECK(LENGTH(email) > 0) NOT NULL UNIQUE,
@ -34,7 +34,8 @@ CREATE TABLE Trips (
CREATE TABLE Sessions (
uuid TEXT CHECK(LENGTH(uuid) == 36) NOT NULL,
username TEXT NOT NULL UNIQUE,
tsCreated TEXT CHECK(LENGTH(tsCreated) == 33) NOT NULL, -- 'YYYY-MM-DD HH:MM:SS'
-- TODO(wpcarro): Add a LENGTH CHECK here
tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS'
PRIMARY KEY (uuid),
FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE
);
@ -46,4 +47,13 @@ CREATE TABLE LoginAttempts (
FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE
);
CREATE TABLE PendingAccounts (
secret TEXT CHECK(LENGTH(secret) == 36) NOT NULL,
username TEXT CHECK(LENGTH(username) > 0) NOT NULL,
password TEXT CHECK(LENGTH(password) > 0) NOT NULL,
role TEXT CHECK(role IN ('user', 'manager', 'admin')) NOT NULL,
email TEXT CHECK(LENGTH(email) > 0) NOT NULL UNIQUE,
PRIMARY KEY (username)
);
COMMIT;