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:
parent
30838b8df7
commit
dec8890190
7 changed files with 178 additions and 31 deletions
|
@ -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,
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
55
src/App.hs
55
src/App.hs
|
@ -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
32
src/PendingAccounts.hs
Normal 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)
|
89
src/Types.hs
89
src/Types.hs
|
@ -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 {..}
|
||||
|
|
14
src/init.sql
14
src/init.sql
|
@ -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;
|
||||
|
|
Loading…
Reference in a new issue