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.

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,

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

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

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
+    createAccount T.CreateAccountRequest{..} = do
-      liftIO $ Accounts.create dbFile
+      secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO
-        (T.createAccountRequestUsername request)
+      liftIO $ PendingAccounts.create dbFile
-        (T.createAccountRequestPassword request)
+        secretUUID
-        (T.createAccountRequestEmail request)
+        createAccountRequestUsername
-        (T.createAccountRequestRole request)
+        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)

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)

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 _ =
+  fromEnv _ = do
-    Config <$> env "MAILGUN_API_KEY"
+    mailgunAPIKey <- env "MAILGUN_API_KEY"
-           <*> env "DB_FILE"
+    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
+  fromRow = do
-                    <*> field
+    accountUsername <- field
-                    <*> field
+    accountPassword <- field
-                    <*> field
+    accountEmail <- field
-                    <*> 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
+  fromRow = do
-                 <*> field
+    tripUsername <- field
-                 <*> field
+    tripDestination <- field
-                 <*> field
+    tripStartDate <- field
-                 <*> 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
+  fromRow = do
-                          <*> field
+    storedSessionUUID <- field
-                          <*> 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 {..}

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;