diff options
| -rw-r--r-- | data/accounts.csv | 1 | ||||
| -rw-r--r-- | src/API.hs | 4 | ||||
| -rw-r--r-- | src/Accounts.hs | 14 | ||||
| -rw-r--r-- | src/App.hs | 55 | ||||
| -rw-r--r-- | src/PendingAccounts.hs | 32 | ||||
| -rw-r--r-- | src/Types.hs | 89 | ||||
| -rw-r--r-- | src/init.sql | 14 |
7 files changed, 178 insertions, 31 deletions
diff --git a/data/accounts.csv b/data/accounts.csv index 1f8b01582c17..f5fc77b6d77f 100644 --- a/data/accounts.csv +++ b/data/accounts.csv @@ -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, \ No newline at end of file diff --git a/src/API.hs b/src/API.hs index 01f7b7b750ce..0ae3112ae84c 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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 diff --git a/src/Accounts.hs b/src/Accounts.hs index c18a599a30a7..97ffaf43d058 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -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 diff --git a/src/App.hs b/src/App.hs index 7536e3c771e1..9a4c3ae2066f 100644 --- a/src/App.hs +++ b/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) diff --git a/src/PendingAccounts.hs b/src/PendingAccounts.hs new file mode 100644 index 000000000000..9f86d1dd0554 --- /dev/null +++ b/src/PendingAccounts.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs index 135c50f17f4a..d03aae9c7f38 100644 --- a/src/Types.hs +++ b/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 {..} diff --git a/src/init.sql b/src/init.sql index 117a3bd06f90..b616fdece52d 100644 --- a/src/init.sql +++ b/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; |