From fd49b7f1bede6d32461e4dc36f53d774b331d021 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 24 Jul 2020 16:21:13 +0100 Subject: [PATCH 01/79] add README --- README.md | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 000000000..e69de29bb From 26271ec178f4edd1bf02b4697fed611915ebc698 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 24 Jul 2020 18:58:04 +0100 Subject: [PATCH 02/79] Create todo.org Create an org file with the instructions sent from TopTal as TODOs. --- todo.org | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 todo.org diff --git a/todo.org b/todo.org new file mode 100644 index 000000000..39592d048 --- /dev/null +++ b/todo.org @@ -0,0 +1,18 @@ +* TODO Users must be able to create an account +* TODO Users must verify their account by email +* TODO Support federated login with Google +* TODO Users must be able to authenticate and login +* TODO Define three roles: user, manager, admin +* TODO Users can add trips +* TODO Users can edit trips +* TODO Users can delete trips +* TODO Users can filter trips +* TODO Support all actions via the REST API +* TODO Block users after three failed authentication attempts +* TODO Only admins and managers can unblock blocked login attempts +* TODO Add unit tests +* TODO Add E2E tests +* TODO Pull user profile pictures using Gravatar +* TODO Allow users to change their profile picture +* TODO Admins should be allowed to invite new users via email +* TODO Allow users to print their travel itineraries From ec90748b827edcd465020acd5bd23ae6a01ba37a Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 24 Jul 2020 18:59:34 +0100 Subject: [PATCH 03/79] Create a shell.nix Manage the project's dependencies using Nix. --- shell.nix | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 shell.nix diff --git a/shell.nix b/shell.nix new file mode 100644 index 000000000..3a5a4ef9e --- /dev/null +++ b/shell.nix @@ -0,0 +1,8 @@ +let + pkgs = import {}; +in pkgs.mkShell { + buildInputs = with pkgs; [ + (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [ + ])) + ]; +} From 660b8d43e5272e2b71b6092b4c879a82c4d861a8 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 24 Jul 2020 19:00:29 +0100 Subject: [PATCH 04/79] Support a basic API Use Servant to create a REST API supporting the following routes: - GET /number - POST /other The server interacts with a SQLite database. --- .gitignore | 1 + shell.nix | 5 +++++ src/API.hs | 39 +++++++++++++++++++++++++++++++++++++++ src/Main.hs | 5 +++++ 4 files changed, 50 insertions(+) create mode 100644 .gitignore create mode 100644 src/API.hs create mode 100644 src/Main.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..e60400359 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +data.db \ No newline at end of file diff --git a/shell.nix b/shell.nix index 3a5a4ef9e..96c18c8e9 100644 --- a/shell.nix +++ b/shell.nix @@ -3,6 +3,11 @@ let in pkgs.mkShell { buildInputs = with pkgs; [ (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [ + hpkgs.servant-server + hpkgs.aeson + hpkgs.resource-pool + hpkgs.sqlite-simple + hpkgs.warp ])) ]; } diff --git a/src/API.hs b/src/API.hs new file mode 100644 index 000000000..b2c7fd57d --- /dev/null +++ b/src/API.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module API where +-------------------------------------------------------------------------------- +import qualified Data.Pool as DP +import qualified Database.SQLite.Simple as DB + +import Data.Aeson +import GHC.Generics +import GHC.TypeLits +import Network.Wai.Handler.Warp +import Servant +import Control.Monad.IO.Class +-------------------------------------------------------------------------------- + +handlers :: DP.Pool DB.Connection -> Server API +handlers pool = do + getHandler pool :<|> pure 0 + +getHandler :: DP.Pool DB.Connection -> Handler Int +getHandler pool = + DP.withResource pool $ \conn -> do + result <- liftIO $ DB.query_ conn "select 2 + 2" + case result of + [DB.Only x] -> pure x + _ -> pure (-1) + +type API = "number" :> Get '[JSON] Int + :<|> "other" :> Post '[JSON] Int + +main :: IO () +main = do + pool <- DP.createPool (DB.open "data.db") DB.close 1 0.5 1 + run 3000 (serve (Proxy @ API) (handlers pool)) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 000000000..7ec8d9f8c --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = do + putStrLn "Working..." From 1d47e94bbe26479ffaaafecd27cdb83d072bfe01 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 24 Jul 2020 22:46:54 +0100 Subject: [PATCH 05/79] Integrate Persistent with Servant Query my SQLite database from within my Servant handlers. Nothing I've written is domain-specific to the business logic yet -- I'm just making sure everything integrates. --- .gitignore | 4 +++- shell.nix | 3 +++ src/API.hs | 45 +++++++++++++--------------------------- src/App.hs | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 6 ++++-- src/Types.hs | 35 +++++++++++++++++++++++++++++++ 6 files changed, 117 insertions(+), 34 deletions(-) create mode 100644 src/App.hs create mode 100644 src/Types.hs diff --git a/.gitignore b/.gitignore index e60400359..c50ada2bf 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ -data.db \ No newline at end of file +*.db +*.db-shm +*.db-wal \ No newline at end of file diff --git a/shell.nix b/shell.nix index 96c18c8e9..3312fef13 100644 --- a/shell.nix +++ b/shell.nix @@ -8,6 +8,9 @@ in pkgs.mkShell { hpkgs.resource-pool hpkgs.sqlite-simple hpkgs.warp + hpkgs.persistent + hpkgs.persistent-sqlite + hpkgs.persistent-template ])) ]; } diff --git a/src/API.hs b/src/API.hs index b2c7fd57d..b46ae5b35 100644 --- a/src/API.hs +++ b/src/API.hs @@ -1,39 +1,22 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- module API where -------------------------------------------------------------------------------- -import qualified Data.Pool as DP -import qualified Database.SQLite.Simple as DB +import Data.Proxy +import Data.Text +import Database.Persist +import Servant.API -import Data.Aeson -import GHC.Generics -import GHC.TypeLits -import Network.Wai.Handler.Warp -import Servant -import Control.Monad.IO.Class +import qualified Types as T -------------------------------------------------------------------------------- -handlers :: DP.Pool DB.Connection -> Server API -handlers pool = do - getHandler pool :<|> pure 0 - -getHandler :: DP.Pool DB.Connection -> Handler Int -getHandler pool = - DP.withResource pool $ \conn -> do - result <- liftIO $ DB.query_ conn "select 2 + 2" - case result of - [DB.Only x] -> pure x - _ -> pure (-1) - -type API = "number" :> Get '[JSON] Int - :<|> "other" :> Post '[JSON] Int - -main :: IO () -main = do - pool <- DP.createPool (DB.open "data.db") DB.close 1 0.5 1 - run 3000 (serve (Proxy @ API) (handlers pool)) +type API = "user" + :> ReqBody '[JSON] T.User + :> Post '[JSON] (Maybe (Key T.User)) + :<|> "user" + :> Capture "name" Text + :> Get '[JSON] (Maybe T.User) diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 000000000..1f7754517 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (runStderrLoggingT) +import Database.Persist.Sqlite ( ConnectionPool, createSqlitePool + , runSqlPool, runSqlPersistMPool + , runMigration, selectFirst, (==.) + , insert, entityVal) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Network.Wai.Handler.Warp as Warp +import Servant + +import API +import Types +-------------------------------------------------------------------------------- + +server :: ConnectionPool -> Server API +server pool = + userAddH :<|> userGetH + where + userAddH newUser = liftIO $ userAdd newUser + userGetH name = liftIO $ userGet name + + userAdd :: User -> IO (Maybe (Key User)) + userAdd newUser = flip runSqlPersistMPool pool $ do + exists <- selectFirst [UserName ==. (userName newUser)] [] + case exists of + Nothing -> Just <$> insert newUser + Just _ -> return Nothing + + userGet :: Text -> IO (Maybe User) + userGet name = flip runSqlPersistMPool pool $ do + mUser <- selectFirst [UserName ==. name] [] + return $ entityVal <$> mUser + +app :: ConnectionPool -> Application +app pool = serve (Proxy @ API) $ server pool + +mkApp :: FilePath -> IO Application +mkApp sqliteFile = do + pool <- runStderrLoggingT $ do + createSqlitePool (cs sqliteFile) 5 + + runSqlPool (runMigration migrateAll) pool + return $ app pool + +run :: FilePath -> IO () +run sqliteFile = + Warp.run 3000 =<< mkApp sqliteFile diff --git a/src/Main.hs b/src/Main.hs index 7ec8d9f8c..ea2ad2621 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,7 @@ module Main where +-------------------------------------------------------------------------------- +import qualified App +-------------------------------------------------------------------------------- main :: IO () -main = do - putStrLn "Working..." +main = App.run "sqlite.db" diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 000000000..3a410dc4b --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-------------------------------------------------------------------------------- +module Types where +-------------------------------------------------------------------------------- +import Data.Aeson +import Data.Text +import Database.Persist.TH +-------------------------------------------------------------------------------- + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +User + name Text + age Int + UniqueName name + deriving Eq Read Show +|] + +instance FromJSON User where + parseJSON = withObject "User" $ \ v -> + User <$> v .: "name" + <*> v .: "age" + +instance ToJSON User where + toJSON (User name age) = + object [ "name" .= name + , "age" .= age + ] From 718152ec14242a83fa63c5272c7527dbbd928ee2 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 24 Jul 2020 23:35:49 +0100 Subject: [PATCH 06/79] Return a Session Define the Session type and return it for the POST /user endpoint --- src/API.hs | 2 +- src/App.hs | 25 +++++++++++++++---------- src/Types.hs | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 49 insertions(+), 11 deletions(-) diff --git a/src/API.hs b/src/API.hs index b46ae5b35..98ffd6094 100644 --- a/src/API.hs +++ b/src/API.hs @@ -16,7 +16,7 @@ import qualified Types as T type API = "user" :> ReqBody '[JSON] T.User - :> Post '[JSON] (Maybe (Key T.User)) + :> Post '[JSON] (Maybe T.Session) :<|> "user" :> Capture "name" Text :> Get '[JSON] (Maybe T.User) diff --git a/src/App.hs b/src/App.hs index 1f7754517..203d1d073 100644 --- a/src/App.hs +++ b/src/App.hs @@ -20,7 +20,7 @@ import Network.Wai.Handler.Warp as Warp import Servant import API -import Types +import qualified Types as T -------------------------------------------------------------------------------- server :: ConnectionPool -> Server API @@ -30,17 +30,22 @@ server pool = userAddH newUser = liftIO $ userAdd newUser userGetH name = liftIO $ userGet name - userAdd :: User -> IO (Maybe (Key User)) + userAdd :: T.User -> IO (Maybe T.Session) userAdd newUser = flip runSqlPersistMPool pool $ do - exists <- selectFirst [UserName ==. (userName newUser)] [] + exists <- selectFirst [T.UserName ==. (T.userName newUser)] [] case exists of - Nothing -> Just <$> insert newUser - Just _ -> return Nothing + Nothing -> do + insert newUser + pure $ Just (T.Session { T.username = T.Username "wpcarro" + , T.password = T.Password "testing" + , T.role = T.RegularUser + }) + Just _ -> pure Nothing - userGet :: Text -> IO (Maybe User) + userGet :: Text -> IO (Maybe T.User) userGet name = flip runSqlPersistMPool pool $ do - mUser <- selectFirst [UserName ==. name] [] - return $ entityVal <$> mUser + mUser <- selectFirst [T.UserName ==. name] [] + pure $ entityVal <$> mUser app :: ConnectionPool -> Application app pool = serve (Proxy @ API) $ server pool @@ -50,8 +55,8 @@ mkApp sqliteFile = do pool <- runStderrLoggingT $ do createSqlitePool (cs sqliteFile) 5 - runSqlPool (runMigration migrateAll) pool - return $ app pool + runSqlPool (runMigration T.migrateAll) pool + pure $ app pool run :: FilePath -> IO () run sqliteFile = diff --git a/src/Types.hs b/src/Types.hs index 3a410dc4b..c2f0ee19b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -33,3 +33,36 @@ instance ToJSON User where object [ "name" .= name , "age" .= age ] + +newtype Username = Username Text + deriving (Eq, Show) + +instance ToJSON Username where + toJSON (Username x) = toJSON x + +newtype Password = Password Text + deriving (Eq, Show) + +instance ToJSON Password where + toJSON (Password x) = toJSON x + +data Role = RegularUser | Manager | Admin + deriving (Eq, Show) + +instance ToJSON Role where + toJSON RegularUser = "user" + toJSON Manager = "manager" + toJSON Admin = "admin" + +data Session = Session + { username :: Username + , password :: Password + , role :: Role + } deriving (Eq, Show) + +instance ToJSON Session where + toJSON (Session username password role) = + object [ "username" .= username + , "password" .= password + , "role" .= role + ] From d01161656419370032f19fd659e30c349cac93cb Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sat, 25 Jul 2020 18:18:59 +0100 Subject: [PATCH 07/79] Change the name User to Account Next I'll need to add / remove fields from the Account type. --- src/API.hs | 4 ++-- src/App.hs | 8 ++++---- src/Types.hs | 12 ++++++------ 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/API.hs b/src/API.hs index 98ffd6094..ae85c8f93 100644 --- a/src/API.hs +++ b/src/API.hs @@ -15,8 +15,8 @@ import qualified Types as T -------------------------------------------------------------------------------- type API = "user" - :> ReqBody '[JSON] T.User + :> ReqBody '[JSON] T.Account :> Post '[JSON] (Maybe T.Session) :<|> "user" :> Capture "name" Text - :> Get '[JSON] (Maybe T.User) + :> Get '[JSON] (Maybe T.Account) diff --git a/src/App.hs b/src/App.hs index 203d1d073..40dc23a30 100644 --- a/src/App.hs +++ b/src/App.hs @@ -30,9 +30,9 @@ server pool = userAddH newUser = liftIO $ userAdd newUser userGetH name = liftIO $ userGet name - userAdd :: T.User -> IO (Maybe T.Session) + userAdd :: T.Account -> IO (Maybe T.Session) userAdd newUser = flip runSqlPersistMPool pool $ do - exists <- selectFirst [T.UserName ==. (T.userName newUser)] [] + exists <- selectFirst [T.AccountName ==. (T.accountName newUser)] [] case exists of Nothing -> do insert newUser @@ -42,9 +42,9 @@ server pool = }) Just _ -> pure Nothing - userGet :: Text -> IO (Maybe T.User) + userGet :: Text -> IO (Maybe T.Account) userGet name = flip runSqlPersistMPool pool $ do - mUser <- selectFirst [T.UserName ==. name] [] + mUser <- selectFirst [T.AccountName ==. name] [] pure $ entityVal <$> mUser app :: ConnectionPool -> Application diff --git a/src/Types.hs b/src/Types.hs index c2f0ee19b..813a4b51c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -16,20 +16,20 @@ import Database.Persist.TH -------------------------------------------------------------------------------- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -User +Account name Text age Int UniqueName name deriving Eq Read Show |] -instance FromJSON User where +instance FromJSON Account where parseJSON = withObject "User" $ \ v -> - User <$> v .: "name" - <*> v .: "age" + Account <$> v .: "name" + <*> v .: "age" -instance ToJSON User where - toJSON (User name age) = +instance ToJSON Account where + toJSON (Account name age) = object [ "name" .= name , "age" .= age ] From 722205b0818a7fb2280941554baaff9400808d65 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sat, 25 Jul 2020 18:32:17 +0100 Subject: [PATCH 08/79] Remodel Account type Remove unnecessary fields: - name - age Add domain-specific fields: - username - password - email - role --- src/App.hs | 4 ++-- src/Types.hs | 29 ++++++++++++++++++++--------- 2 files changed, 22 insertions(+), 11 deletions(-) diff --git a/src/App.hs b/src/App.hs index 40dc23a30..a13ffa2d3 100644 --- a/src/App.hs +++ b/src/App.hs @@ -32,7 +32,7 @@ server pool = userAdd :: T.Account -> IO (Maybe T.Session) userAdd newUser = flip runSqlPersistMPool pool $ do - exists <- selectFirst [T.AccountName ==. (T.accountName newUser)] [] + exists <- selectFirst [T.AccountUsername ==. (T.accountUsername newUser)] [] case exists of Nothing -> do insert newUser @@ -44,7 +44,7 @@ server pool = userGet :: Text -> IO (Maybe T.Account) userGet name = flip runSqlPersistMPool pool $ do - mUser <- selectFirst [T.AccountName ==. name] [] + mUser <- selectFirst [T.AccountUsername ==. name] [] pure $ entityVal <$> mUser app :: ConnectionPool -> Application diff --git a/src/Types.hs b/src/Types.hs index 813a4b51c..fc1516e5b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} -------------------------------------------------------------------------------- module Types where -------------------------------------------------------------------------------- @@ -17,21 +18,31 @@ import Database.Persist.TH share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Account - name Text - age Int - UniqueName name + username Text + password Text + email Text + role Text + UniqueUsername username + UniqueEmail email deriving Eq Read Show |] instance FromJSON Account where - parseJSON = withObject "User" $ \ v -> - Account <$> v .: "name" - <*> v .: "age" + parseJSON = withObject "Account" $ \ v -> + Account <$> v .: "username" + <*> v .: "password" + <*> v .: "email" + <*> v .: "role" instance ToJSON Account where - toJSON (Account name age) = - object [ "name" .= name - , "age" .= age + toJSON (Account{ accountUsername + , accountPassword + , accountEmail + , accountRole }) = + object [ "username" .= accountUsername + , "password" .= accountPassword + , "email" .= accountEmail + , "role" .= accountRole ] newtype Username = Username Text From df13b761ff945db894ade4dba6c68fb6f14c8615 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Mon, 27 Jul 2020 11:16:26 +0100 Subject: [PATCH 09/79] Define table schema and CSVs to populate the database TL;DR: - Created src/init.sql, which defines the tables - Created a data/ directory to house .csv data to populate our db - Updated the README with usage instructions --- .gitignore | 1 + README.md | 44 ++++++++++++++++++++++++++++++++++++++++++++ data/accounts.csv | 3 +++ data/trips.csv | 3 +++ src/init.sql | 31 +++++++++++++++++++++++++++++++ 5 files changed, 82 insertions(+) create mode 100644 data/accounts.csv create mode 100644 data/trips.csv create mode 100644 src/init.sql diff --git a/.gitignore b/.gitignore index c50ada2bf..aa7648cec 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *.db +*.sqlite3 *.db-shm *.db-wal \ No newline at end of file diff --git a/README.md b/README.md index e69de29bb..e6d20d649 100644 --- a/README.md +++ b/README.md @@ -0,0 +1,44 @@ +# TopTal take-home #2 + +All of the commands defined herein should be run from the top-level directory of +this repository (i.e. the directory in which this file exists). + +## Database + +Create a new database named `db.sqlite3` with: + +```shell +$ sqlite3 db.sqlite3 +``` + +Initialize the schema with: + +``` +sqlite> .read src/init.sql +``` + +You can verify that you successfully initialized the database by running: + +``` +sqlite> .tables +sqlite> .schema Accounts +sqlite> .schema Trips +``` + +Populate the database with some dummy values using the following: + +``` +sqlite> PRAGMA foreign_keys = on; +sqlite> .mode csv +sqlite> .import data/accounts.csv Accounts +sqlite> .import data/trips.csv Trips +``` + +You can verify you successfully populated the tables with: + +``` +sqlite> .mode columns +sqlite> .headers on +sqlite> SELECT * FROM Accounts; +sqlite> SELECT * FROM Trips; +``` diff --git a/data/accounts.csv b/data/accounts.csv new file mode 100644 index 000000000..51af23eec --- /dev/null +++ b/data/accounts.csv @@ -0,0 +1,3 @@ +mimi,testing,miriamwright@google.com,user, +bill,testing,wpcarro@gmail.com,manager, +wpcarro,testing,wpcarro@google.com,admin, \ No newline at end of file diff --git a/data/trips.csv b/data/trips.csv new file mode 100644 index 000000000..3377efeba --- /dev/null +++ b/data/trips.csv @@ -0,0 +1,3 @@ +mimi,Rome,2020-08-10,2020-15-30,Heading home before the upcoming trip with Panarea. +mimi,Panarea,2020-08-15,2020-05-30,Exciting upcoming trip with Matt and Sarah! +mimi,London,2020-08-30,2020-08-30,Heading back to London... \ No newline at end of file diff --git a/src/init.sql b/src/init.sql new file mode 100644 index 000000000..951ea3ecb --- /dev/null +++ b/src/init.sql @@ -0,0 +1,31 @@ +-- Run `.read init.sql` from within a SQLite3 REPL to initialize the tables we +-- need for this application. This will erase all current entries, so use with +-- caution. +-- Make sure to set `PRAGMA foreign_keys = on;` when transacting with the +-- database. + +BEGIN TRANSACTION; + +DROP TABLE IF EXISTS Accounts; +DROP TABLE IF EXISTS Trips; + +CREATE TABLE Accounts ( + username TEXT NOT NULL, + password TEXT NOT NULL, + email TEXT NOT NULL UNIQUE, + role TEXT NOT NULL, + profilePicture BLOB, + PRIMARY KEY (username) +); + +CREATE TABLE Trips ( + username TEXT NOT NULL, + destination TEXT NOT NULL, + startDate TEXT NOT NULL, -- YYYY-MM-DD + endDate TEXT NOT NULL, -- YYYY-MM-DD + comment TEXT NOT NULL, + PRIMARY KEY (username, destination, startDate), + FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE +); + +COMMIT; From 974c63a679de8975d7f6593f986d3acc47506a7d Mon Sep 17 00:00:00 2001 From: William Carroll Date: Mon, 27 Jul 2020 11:35:10 +0100 Subject: [PATCH 10/79] Remove unnecessary language extensions Attempting to abide by the Principle of Least Power. Also: the smaller the headers in each module are, the happier I am. --- src/API.hs | 5 ----- src/App.hs | 5 ----- src/Types.hs | 2 -- 3 files changed, 12 deletions(-) diff --git a/src/API.hs b/src/API.hs index ae85c8f93..70da1921d 100644 --- a/src/API.hs +++ b/src/API.hs @@ -1,14 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- module API where -------------------------------------------------------------------------------- -import Data.Proxy import Data.Text -import Database.Persist import Servant.API import qualified Types as T diff --git a/src/App.hs b/src/App.hs index a13ffa2d3..4381882d1 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- module App where -------------------------------------------------------------------------------- diff --git a/src/Types.hs b/src/Types.hs index fc1516e5b..083724961 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} From dfe23e3b63ab61361fa34247abde006355f3914a Mon Sep 17 00:00:00 2001 From: William Carroll Date: Mon, 27 Jul 2020 11:36:09 +0100 Subject: [PATCH 11/79] Add instruction for operating the server Add some basic commands for working with the server from within `ghci`, which is helpful when developing. --- README.md | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/README.md b/README.md index e6d20d649..2e5f2f18d 100644 --- a/README.md +++ b/README.md @@ -3,6 +3,29 @@ All of the commands defined herein should be run from the top-level directory of this repository (i.e. the directory in which this file exists). +## Server + +To create the environment that contains all of this application's dependencies, +run: + +```shell +$ nix-shell +``` + +To run the server interactively, run: + +```shell +$ cd src/ +$ ghci +``` + +Now compile and load the server with: + +``` +Prelude> :l Main.hs +*Main> main +``` + ## Database Create a new database named `db.sqlite3` with: From c38814d7a155e5ced75b088b29cafa71a4a76de0 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Mon, 27 Jul 2020 14:21:32 +0100 Subject: [PATCH 12/79] Add CHECK constraints to schema I believe data should be validated at each level of the stack: - database - server - client The database, in my opinion, is the most important layer at which to validate because you can eliminate entire classes of bugs. However, the CHECK constraint is limited, and the more complex the predicates are, the more expensive database operations become. At the server and client layers, the data validations can be more sophisticated and return more useful error messages to help users better understand the shape of the data that our application expects. --- src/init.sql | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/init.sql b/src/init.sql index 951ea3ecb..f1109feac 100644 --- a/src/init.sql +++ b/src/init.sql @@ -10,19 +10,20 @@ DROP TABLE IF EXISTS Accounts; DROP TABLE IF EXISTS Trips; CREATE TABLE Accounts ( - username TEXT NOT NULL, - password TEXT NOT NULL, - email TEXT NOT NULL UNIQUE, - role TEXT NOT NULL, +-- 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, + role TEXT CHECK(role IN ('user', 'manager', 'admin')) NOT NULL, profilePicture BLOB, PRIMARY KEY (username) ); CREATE TABLE Trips ( username TEXT NOT NULL, - destination TEXT NOT NULL, - startDate TEXT NOT NULL, -- YYYY-MM-DD - endDate TEXT NOT NULL, -- YYYY-MM-DD + destination TEXT CHECK(LENGTH(destination) > 0) NOT NULL, + startDate TEXT CHECK(LENGTH(startDate) == 10) NOT NULL, -- YYYY-MM-DD + endDate TEXT CHECK(LENGTH(endDate) == 10) NOT NULL, -- YYYY-MM-DD comment TEXT NOT NULL, PRIMARY KEY (username, destination, startDate), FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE From 475f62fb16fb29e55548cc8b238caea8bf60bd8f Mon Sep 17 00:00:00 2001 From: William Carroll Date: Mon, 27 Jul 2020 15:22:22 +0100 Subject: [PATCH 13/79] Prefer SQLite.Simple to Persistent In the spirit of walking crawling before I walk, I'm preferring the less powerful SQLite.Simple library to the more powerful (but mystifying) Persistent library. --- src/App.hs | 47 +++++++--------- src/Main.hs | 2 +- src/Types.hs | 147 +++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 128 insertions(+), 68 deletions(-) diff --git a/src/App.hs b/src/App.hs index 4381882d1..b80a3ba4f 100644 --- a/src/App.hs +++ b/src/App.hs @@ -5,12 +5,10 @@ module App where -------------------------------------------------------------------------------- import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (runStderrLoggingT) -import Database.Persist.Sqlite ( ConnectionPool, createSqlitePool - , runSqlPool, runSqlPersistMPool - , runMigration, selectFirst, (==.) - , insert, entityVal) +import Data.Function ((&)) import Data.String.Conversions (cs) import Data.Text (Text) +import Database.SQLite.Simple import Network.Wai.Handler.Warp as Warp import Servant @@ -18,40 +16,33 @@ import API import qualified Types as T -------------------------------------------------------------------------------- -server :: ConnectionPool -> Server API -server pool = +server :: FilePath -> Server API +server dbFile = userAddH :<|> userGetH where userAddH newUser = liftIO $ userAdd newUser userGetH name = liftIO $ userGet name + -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s userAdd :: T.Account -> IO (Maybe T.Session) - userAdd newUser = flip runSqlPersistMPool pool $ do - exists <- selectFirst [T.AccountUsername ==. (T.accountUsername newUser)] [] - case exists of - Nothing -> do - insert newUser - pure $ Just (T.Session { T.username = T.Username "wpcarro" - , T.password = T.Password "testing" - , T.role = T.RegularUser - }) - Just _ -> pure Nothing + userAdd account = withConnection dbFile $ \conn -> do + execute conn "INSERT INTO Accounts (username,password,email,role,profilePicture) VALUES (?,?,?,?,?)" + (account & T.accountFields) + T.Session{ T.username = T.accountUsername account + , T.password = T.accountPassword account + , T.role = T.accountRole account + } & Just & pure userGet :: Text -> IO (Maybe T.Account) - userGet name = flip runSqlPersistMPool pool $ do - mUser <- selectFirst [T.AccountUsername ==. name] [] - pure $ entityVal <$> mUser - -app :: ConnectionPool -> Application -app pool = serve (Proxy @ API) $ server pool + userGet name = withConnection dbFile $ \conn -> do + res <- query conn "SELECT * FROM Accounts WHERE username = ?" (Only name) + case res of + [x] -> pure (Just x) + _ -> pure Nothing mkApp :: FilePath -> IO Application -mkApp sqliteFile = do - pool <- runStderrLoggingT $ do - createSqlitePool (cs sqliteFile) 5 - - runSqlPool (runMigration T.migrateAll) pool - pure $ app pool +mkApp dbFile = do + pure $ serve (Proxy @ API) $ server dbFile run :: FilePath -> IO () run sqliteFile = diff --git a/src/Main.hs b/src/Main.hs index ea2ad2621..de40b3225 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,4 +4,4 @@ import qualified App -------------------------------------------------------------------------------- main :: IO () -main = App.run "sqlite.db" +main = App.run "../db.sqlite3" diff --git a/src/Types.hs b/src/Types.hs index 083724961..d57fa92ed 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -10,58 +11,126 @@ module Types where -------------------------------------------------------------------------------- import Data.Aeson +import Data.Function ((&)) import Data.Text +import Data.Typeable import Database.Persist.TH +import Database.SQLite.Simple +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +import GHC.Generics + +import qualified Data.ByteString as BS -------------------------------------------------------------------------------- -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -Account - username Text - password Text - email Text - role Text - UniqueUsername username - UniqueEmail email - deriving Eq Read Show -|] - -instance FromJSON Account where - parseJSON = withObject "Account" $ \ v -> - Account <$> v .: "username" - <*> v .: "password" - <*> v .: "email" - <*> v .: "role" - -instance ToJSON Account where - toJSON (Account{ accountUsername - , accountPassword - , accountEmail - , accountRole }) = - object [ "username" .= accountUsername - , "password" .= accountPassword - , "email" .= accountEmail - , "role" .= accountRole - ] +-- 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 "" newtype Username = Username Text - deriving (Eq, Show) + deriving (Eq, Show, Generic) -instance ToJSON Username where - toJSON (Username x) = toJSON x +instance ToJSON Username +instance FromJSON Username + +instance ToField Username where + toField (Username x) = SQLText x + +instance FromField Username where + fromField = forNewtype Username newtype Password = Password Text - deriving (Eq, Show) + deriving (Eq, Show, Generic) -instance ToJSON Password where - toJSON (Password x) = toJSON x +instance ToJSON Password +instance FromJSON Password + +instance ToField Password where + toField (Password x) = SQLText x + +instance FromField Password where + fromField = forNewtype Password + +newtype Email = Email Text + deriving (Eq, Show, Generic) + +instance ToJSON Email +instance FromJSON Email + +instance ToField Email where + toField (Email x) = SQLText x + +instance FromField Email where + fromField = forNewtype Email data Role = RegularUser | Manager | Admin - deriving (Eq, Show) + deriving (Eq, Show, Generic) -instance ToJSON Role where - toJSON RegularUser = "user" - toJSON Manager = "manager" - toJSON Admin = "admin" +instance ToJSON Role +instance FromJSON Role + +instance ToField Role where + toField RegularUser = SQLText "user" + toField Manager = SQLText "manager" + toField Admin = SQLText "admin" + +instance FromField Role where + fromField field = + case fieldData field of + (SQLText "user") -> Ok RegularUser + (SQLText "manager") -> Ok Manager + (SQLText "admin") -> Ok Admin + _ -> returnError ConversionFailed field "" + +-- TODO(wpcarro): Prefer Data.ByteString instead of Text +newtype ProfilePicture = ProfilePicture Text + deriving (Eq, Show, Generic) + +instance ToJSON ProfilePicture +instance FromJSON ProfilePicture + +instance ToField ProfilePicture where + toField (ProfilePicture x) = SQLText x + +instance FromField ProfilePicture where + fromField = forNewtype ProfilePicture + +data Account = Account + { accountUsername :: Username + , accountPassword :: Password + , accountEmail :: Email + , accountRole :: Role + , accountProfilePicture :: ProfilePicture + } deriving (Eq, Show, Generic) + +instance FromJSON Account +instance ToJSON Account + +-- | Return a tuple with all of the fields for an Account record to use for SQL. +accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture) +accountFields (Account { accountUsername + , accountPassword + , accountEmail + , accountRole + , accountProfilePicture + }) + = ( accountUsername + , accountPassword + , accountEmail + , accountRole + , accountProfilePicture + ) + +instance FromRow Account where + fromRow = Account <$> field + <*> field + <*> field + <*> field + <*> field data Session = Session { username :: Username From 52ac4d79bda2c5f5cc2ff636e79b4bf3b5979868 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 09:10:54 +0100 Subject: [PATCH 14/79] Allow API users to create Trip entries Next up: - list trips - update existing trip entries - delete existing trip entries --- src/API.hs | 3 +++ src/App.hs | 12 ++++++++-- src/Types.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 79 insertions(+), 3 deletions(-) diff --git a/src/API.hs b/src/API.hs index 70da1921d..f858e6d7a 100644 --- a/src/API.hs +++ b/src/API.hs @@ -15,3 +15,6 @@ type API = "user" :<|> "user" :> Capture "name" Text :> Get '[JSON] (Maybe T.Account) + :<|> "trip" + :> ReqBody '[JSON] T.Trip + :> Post '[JSON] Bool diff --git a/src/App.hs b/src/App.hs index b80a3ba4f..20d99e385 100644 --- a/src/App.hs +++ b/src/App.hs @@ -17,11 +17,13 @@ import qualified Types as T -------------------------------------------------------------------------------- server :: FilePath -> Server API -server dbFile = - userAddH :<|> userGetH +server dbFile = userAddH + :<|> userGetH + :<|> createTripH where userAddH newUser = liftIO $ userAdd newUser userGetH name = liftIO $ userGet name + createTripH trip = liftIO $ createTrip trip -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s userAdd :: T.Account -> IO (Maybe T.Session) @@ -40,6 +42,12 @@ server dbFile = [x] -> pure (Just x) _ -> pure Nothing + createTrip :: T.Trip -> IO Bool + createTrip trip = withConnection dbFile $ \conn -> do + execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" + (trip & T.tripFields) + pure True + mkApp :: FilePath -> IO Application mkApp dbFile = do pure $ serve (Proxy @ API) $ server dbFile diff --git a/src/Types.hs b/src/Types.hs index d57fa92ed..14536ae8c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -107,8 +107,9 @@ data Account = Account , accountProfilePicture :: ProfilePicture } deriving (Eq, Show, Generic) -instance FromJSON Account +-- TODO(wpcarro): Prefer username to accountUsername for JSON instance ToJSON Account +instance FromJSON Account -- | Return a tuple with all of the fields for an Account record to use for SQL. accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture) @@ -144,3 +145,67 @@ instance ToJSON Session where , "password" .= password , "role" .= role ] + +newtype Comment = Comment Text + deriving (Eq, Show, Generic) + +instance ToJSON Comment +instance FromJSON Comment + +instance ToField Comment where + toField (Comment x) = SQLText x + +instance FromField Comment where + fromField = forNewtype Comment + +-- TODO(wpcarro): Replace this with a different type. +newtype Date = Date Text + deriving (Eq, Show, Generic) + +instance ToJSON Date +instance FromJSON Date + +instance ToField Date where + toField (Date x) = SQLText x + +instance FromField Date where + fromField = forNewtype Date + +newtype Destination = Destination Text + deriving (Eq, Show, Generic) + +-- TODO(wpcarro): Prefer username to tripUsername for JSON +instance ToJSON Destination +instance FromJSON Destination + +instance ToField Destination where + toField (Destination x) = SQLText x + +instance FromField Destination where + fromField = forNewtype Destination + +data Trip = Trip + { tripUsername :: Username + , tripDestination :: Destination + , tripStartDate :: Date + , tripEndDate :: Date + , tripComment :: Comment + } deriving (Eq, Show, Generic) + +-- | Return the tuple representation of a Trip record for SQL. +tripFields :: Trip -> (Username, Destination, Date, Date, Comment) +tripFields (Trip{ tripUsername + , tripDestination + , tripStartDate + , tripEndDate + , tripComment + }) + = ( tripUsername + , tripDestination + , tripStartDate + , tripEndDate + , tripComment + ) + +instance ToJSON Trip +instance FromJSON Trip From 2f73d1db6c2ec107a9af1572f023b6c95133229c Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 10:12:25 +0100 Subject: [PATCH 15/79] Prefer NoContent response to Bool When I first wrote this handler I wasn't aware of the NoContent response option. --- src/API.hs | 2 +- src/App.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/API.hs b/src/API.hs index f858e6d7a..ef185e246 100644 --- a/src/API.hs +++ b/src/API.hs @@ -17,4 +17,4 @@ type API = "user" :> Get '[JSON] (Maybe T.Account) :<|> "trip" :> ReqBody '[JSON] T.Trip - :> Post '[JSON] Bool + :> Post '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index 20d99e385..d244c9b56 100644 --- a/src/App.hs +++ b/src/App.hs @@ -42,11 +42,11 @@ server dbFile = userAddH [x] -> pure (Just x) _ -> pure Nothing - createTrip :: T.Trip -> IO Bool + createTrip :: T.Trip -> IO NoContent createTrip trip = withConnection dbFile $ \conn -> do execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" (trip & T.tripFields) - pure True + pure NoContent mkApp :: FilePath -> IO Application mkApp dbFile = do From 0637da36ccac7e609041bc8999e3da348171f95f Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 10:13:38 +0100 Subject: [PATCH 16/79] Support GET /trips In the spirit of support CRUDL, I added a GET /trips, which lists all of the trips in the Trips table. --- src/API.hs | 3 +++ src/App.hs | 5 +++++ src/Types.hs | 7 +++++++ 3 files changed, 15 insertions(+) diff --git a/src/API.hs b/src/API.hs index ef185e246..a42bf804b 100644 --- a/src/API.hs +++ b/src/API.hs @@ -18,3 +18,6 @@ type API = "user" :<|> "trip" :> ReqBody '[JSON] T.Trip :> Post '[JSON] NoContent + -- Read + :<|> "trips" + :> Get '[JSON] [T.Trip] diff --git a/src/App.hs b/src/App.hs index d244c9b56..c4203137a 100644 --- a/src/App.hs +++ b/src/App.hs @@ -20,10 +20,12 @@ server :: FilePath -> Server API server dbFile = userAddH :<|> userGetH :<|> createTripH + :<|> listTripsH where userAddH newUser = liftIO $ userAdd newUser userGetH name = liftIO $ userGet name createTripH trip = liftIO $ createTrip trip + listTripsH = liftIO $ listTrips -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s userAdd :: T.Account -> IO (Maybe T.Session) @@ -48,6 +50,9 @@ server dbFile = userAddH (trip & T.tripFields) pure NoContent + listTrips :: IO [T.Trip] + listTrips = withConnection dbFile $ \conn -> do + query_ conn "SELECT * FROM Trips" mkApp :: FilePath -> IO Application mkApp dbFile = do pure $ serve (Proxy @ API) $ server dbFile diff --git a/src/Types.hs b/src/Types.hs index 14536ae8c..112b17c53 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -192,6 +192,13 @@ data Trip = Trip , tripComment :: Comment } deriving (Eq, Show, Generic) +instance FromRow Trip where + fromRow = Trip <$> field + <*> field + <*> field + <*> field + <*> field + -- | Return the tuple representation of a Trip record for SQL. tripFields :: Trip -> (Username, Destination, Date, Date, Comment) tripFields (Trip{ tripUsername From 6d9e76313d1f89dcf4c1adb7bfabd811a65bd83a Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 10:14:33 +0100 Subject: [PATCH 17/79] Partially support DELETE /trips Allow a user to delete a trip entry from the Trips table using the Primary Key. While this type-checks and compiles, it doesn't appear to be working as intended. Perhaps I should use an auto-incrementing integer as the Primary Key. I'm not sure how I want to handle this, so I'm punting for now. --- src/API.hs | 9 +++++++-- src/App.hs | 17 ++++++++++++++--- src/Types.hs | 18 ++++++++++++++++++ 3 files changed, 39 insertions(+), 5 deletions(-) diff --git a/src/API.hs b/src/API.hs index a42bf804b..545aa25be 100644 --- a/src/API.hs +++ b/src/API.hs @@ -14,10 +14,15 @@ type API = "user" :> Post '[JSON] (Maybe T.Session) :<|> "user" :> Capture "name" Text - :> Get '[JSON] (Maybe T.Account) - :<|> "trip" + :> Get '[JSON] (Maybe T.Account) + -- Create + :<|> "trips" :> ReqBody '[JSON] T.Trip :> Post '[JSON] NoContent -- Read :<|> "trips" :> Get '[JSON] [T.Trip] + -- Delete + :<|> "trips" + :> ReqBody '[JSON] T.TripPK + :> Delete '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index c4203137a..774795192 100644 --- a/src/App.hs +++ b/src/App.hs @@ -21,11 +21,13 @@ server dbFile = userAddH :<|> userGetH :<|> createTripH :<|> listTripsH + :<|> deleteTripH where - userAddH newUser = liftIO $ userAdd newUser - userGetH name = liftIO $ userGet name - createTripH trip = liftIO $ createTrip trip + userAddH newUser = liftIO $ userAdd newUser + userGetH name = liftIO $ userGet name + createTripH trip = liftIO $ createTrip trip listTripsH = liftIO $ listTrips + deleteTripH tripPK = liftIO $ deleteTrip tripPK -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s userAdd :: T.Account -> IO (Maybe T.Session) @@ -53,6 +55,15 @@ server dbFile = userAddH listTrips :: IO [T.Trip] listTrips = withConnection dbFile $ \conn -> do query_ conn "SELECT * FROM Trips" + + -- TODO(wpcarro): Validate incoming data like startDate. + deleteTrip :: T.TripPK -> IO NoContent + deleteTrip tripPK = + withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" + (tripPK & T.tripPKFields) + pure NoContent + mkApp :: FilePath -> IO Application mkApp dbFile = do pure $ serve (Proxy @ API) $ server dbFile diff --git a/src/Types.hs b/src/Types.hs index 112b17c53..6d6b83347 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -199,6 +199,24 @@ instance FromRow Trip where <*> field <*> field +-- | The fields used as the Primary Key for a Trip entry. +data TripPK = TripPK + { tripPKUsername :: Username + , tripPKDestination :: Destination + , tripPKStartDate :: Date + } deriving (Eq, Show, Generic) + +tripPKFields :: TripPK -> (Username, Destination, Date) +tripPKFields (TripPK{ tripPKUsername + , tripPKDestination + , tripPKStartDate + }) + = (tripPKUsername, tripPKDestination, tripPKStartDate) + +-- TODO(wpcarro): Prefer shorter JSON fields like username instead of +-- tripPKUsername. +instance FromJSON TripPK + -- | Return the tuple representation of a Trip record for SQL. tripFields :: Trip -> (Username, Destination, Date, Date, Comment) tripFields (Trip{ tripUsername From 2398f1bd40235ce4ff031dccbde4d04b32395292 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 10:57:15 +0100 Subject: [PATCH 18/79] Distinguish b/w Account and User Additionally: supporting more CRUDL methods for the Accounts and Trips tables. --- src/API.hs | 29 ++++++++++++++++++++--------- src/App.hs | 41 ++++++++++++++++++++++++----------------- src/Types.hs | 19 +++++++++++++++++++ 3 files changed, 63 insertions(+), 26 deletions(-) diff --git a/src/API.hs b/src/API.hs index 545aa25be..95b9f14a3 100644 --- a/src/API.hs +++ b/src/API.hs @@ -9,20 +9,31 @@ import Servant.API import qualified Types as T -------------------------------------------------------------------------------- -type API = "user" +type API = + -- accounts: Create + "accounts" :> ReqBody '[JSON] T.Account :> Post '[JSON] (Maybe T.Session) - :<|> "user" - :> Capture "name" Text - :> Get '[JSON] (Maybe T.Account) - -- Create + -- accounts: Read + -- accounts: Update + -- accounts: Delete + :<|> "accounts" + :> QueryParam' '[Required] "username" Text + :> Delete '[JSON] NoContent + -- accounts: List + :<|> "accounts" + :> Get '[JSON] [T.User] + + -- trips: Create :<|> "trips" :> ReqBody '[JSON] T.Trip :> Post '[JSON] NoContent - -- Read - :<|> "trips" - :> Get '[JSON] [T.Trip] - -- Delete + -- trips: Read + -- trips: Update + -- trips: Delete :<|> "trips" :> ReqBody '[JSON] T.TripPK :> Delete '[JSON] NoContent + -- trips: List + :<|> "trips" + :> Get '[JSON] [T.Trip] diff --git a/src/App.hs b/src/App.hs index 774795192..8e169f9f8 100644 --- a/src/App.hs +++ b/src/App.hs @@ -17,21 +17,24 @@ import qualified Types as T -------------------------------------------------------------------------------- server :: FilePath -> Server API -server dbFile = userAddH - :<|> userGetH +server dbFile = createAccountH + :<|> deleteAccountH + :<|> listAccountsH :<|> createTripH - :<|> listTripsH :<|> deleteTripH + :<|> listTripsH where - userAddH newUser = liftIO $ userAdd newUser - userGetH name = liftIO $ userGet name - createTripH trip = liftIO $ createTrip trip - listTripsH = liftIO $ listTrips - deleteTripH tripPK = liftIO $ deleteTrip tripPK + createAccountH newUser = liftIO $ createAccount newUser + deleteAccountH username = liftIO $ deleteAccount username + listAccountsH = liftIO $ listAccounts + + createTripH trip = liftIO $ createTrip trip + deleteTripH tripPK = liftIO $ deleteTrip tripPK + listTripsH = liftIO $ listTrips -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s - userAdd :: T.Account -> IO (Maybe T.Session) - userAdd account = withConnection dbFile $ \conn -> do + createAccount :: T.Account -> IO (Maybe T.Session) + createAccount account = withConnection dbFile $ \conn -> do execute conn "INSERT INTO Accounts (username,password,email,role,profilePicture) VALUES (?,?,?,?,?)" (account & T.accountFields) T.Session{ T.username = T.accountUsername account @@ -39,12 +42,16 @@ server dbFile = userAddH , T.role = T.accountRole account } & Just & pure - userGet :: Text -> IO (Maybe T.Account) - userGet name = withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Accounts WHERE username = ?" (Only name) - case res of - [x] -> pure (Just x) - _ -> pure Nothing + deleteAccount :: Text -> IO NoContent + deleteAccount username = withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Accounts WHERE username = ?" + (Only (T.Username username)) + pure NoContent + + listAccounts :: IO [T.User] + listAccounts = withConnection dbFile $ \conn -> do + accounts <- query_ conn "SELECT * FROM Accounts" + pure $ T.userFromAccount <$> accounts createTrip :: T.Trip -> IO NoContent createTrip trip = withConnection dbFile $ \conn -> do @@ -53,7 +60,7 @@ server dbFile = userAddH pure NoContent listTrips :: IO [T.Trip] - listTrips = withConnection dbFile $ \conn -> do + listTrips = withConnection dbFile $ \conn -> query_ conn "SELECT * FROM Trips" -- TODO(wpcarro): Validate incoming data like startDate. diff --git a/src/Types.hs b/src/Types.hs index 6d6b83347..2f78ddb9a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -234,3 +234,22 @@ tripFields (Trip{ tripUsername instance ToJSON Trip instance FromJSON Trip + +-- | Users and Accounts both refer to the same underlying entities; however, +-- Users model the user-facing Account details, hiding sensitive details like +-- passwords and emails. +data User = User + { userUsername :: Username + , userProfilePicture :: ProfilePicture + , userRole :: Role + } deriving (Eq, Show, Generic) + +instance ToJSON User +instance FromJSON User + +userFromAccount :: Account -> User +userFromAccount account = + User { userUsername = accountUsername account + , userProfilePicture = accountProfilePicture account + , userRole = accountRole account + } From 502126243d221fc56345ccd7e4b72882f2128953 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 11:19:05 +0100 Subject: [PATCH 19/79] Prefer name ClearTextPassword to Password I expect my application to have two types for passwords: - ClearTextPassword - CipherTextPassword --- src/Types.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 2f78ddb9a..bd4544deb 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -43,17 +43,17 @@ instance ToField Username where instance FromField Username where fromField = forNewtype Username -newtype Password = Password Text +newtype ClearTextPassword = ClearTextPassword Text deriving (Eq, Show, Generic) -instance ToJSON Password -instance FromJSON Password +instance ToJSON ClearTextPassword +instance FromJSON ClearTextPassword -instance ToField Password where - toField (Password x) = SQLText x +instance ToField ClearTextPassword where + toField (ClearTextPassword x) = SQLText x -instance FromField Password where - fromField = forNewtype Password +instance FromField ClearTextPassword where + fromField = forNewtype ClearTextPassword newtype Email = Email Text deriving (Eq, Show, Generic) @@ -101,7 +101,7 @@ instance FromField ProfilePicture where data Account = Account { accountUsername :: Username - , accountPassword :: Password + , accountPassword :: ClearTextPassword , accountEmail :: Email , accountRole :: Role , accountProfilePicture :: ProfilePicture @@ -112,7 +112,7 @@ instance ToJSON Account instance FromJSON Account -- | Return a tuple with all of the fields for an Account record to use for SQL. -accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture) +accountFields :: Account -> (Username, ClearTextPassword, Email, Role, ProfilePicture) accountFields (Account { accountUsername , accountPassword , accountEmail @@ -135,7 +135,7 @@ instance FromRow Account where data Session = Session { username :: Username - , password :: Password + , password :: ClearTextPassword , role :: Role } deriving (Eq, Show) From bb36dd1f9e7dfaa806fbda1317b9e53aed49b4ea Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 11:20:15 +0100 Subject: [PATCH 20/79] Define bespoke impls for {To,From}JSON instances Instead of sending and receiving JSON like "accountUsername", which leaks implementation details and is a bit unwieldy, define custom instances that prefer the shorter, more user-friendly "username" version. --- src/Types.hs | 85 +++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 74 insertions(+), 11 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index bd4544deb..713dd5193 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -107,9 +107,28 @@ data Account = Account , accountProfilePicture :: ProfilePicture } deriving (Eq, Show, Generic) --- TODO(wpcarro): Prefer username to accountUsername for JSON -instance ToJSON Account -instance FromJSON Account +instance ToJSON Account where + toJSON (Account username password email role profilePicture) = + object [ "username" .= username + , "password" .= password + , "email" .= email + , "role" .= role + , "profilePicture" .= profilePicture + ] + +instance FromJSON Account where + parseJSON = withObject "Account" $ \x -> do + username <- x .: "username" + password <- x .: "password" + email <- x .: "email" + role <- x .: "role" + profilePicture <- x .: "profilePicture" + pure Account{ accountUsername = username + , accountPassword = password + , accountEmail = email + , accountRole = role + , accountProfilePicture = profilePicture + } -- | Return a tuple with all of the fields for an Account record to use for SQL. accountFields :: Account -> (Username, ClearTextPassword, Email, Role, ProfilePicture) @@ -174,7 +193,6 @@ instance FromField Date where newtype Destination = Destination Text deriving (Eq, Show, Generic) --- TODO(wpcarro): Prefer username to tripUsername for JSON instance ToJSON Destination instance FromJSON Destination @@ -213,9 +231,15 @@ tripPKFields (TripPK{ tripPKUsername }) = (tripPKUsername, tripPKDestination, tripPKStartDate) --- TODO(wpcarro): Prefer shorter JSON fields like username instead of --- tripPKUsername. -instance FromJSON TripPK +instance FromJSON TripPK where + parseJSON = withObject "TripPK" $ \x -> do + username <- x .: "username" + destination <- x .: "destination" + startDate <- x .: "startDate" + pure TripPK{ tripPKUsername = username + , tripPKDestination = destination + , tripPKStartDate = startDate + } -- | Return the tuple representation of a Trip record for SQL. tripFields :: Trip -> (Username, Destination, Date, Date, Comment) @@ -232,8 +256,28 @@ tripFields (Trip{ tripUsername , tripComment ) -instance ToJSON Trip -instance FromJSON Trip +instance ToJSON Trip where + toJSON (Trip username destination startDate endDate comment) = + object [ "username" .= username + , "destination" .= destination + , "startDate" .= startDate + , "endDate" .= endDate + , "comment" .= comment + ] + +instance FromJSON Trip where + parseJSON = withObject "Trip" $ \x -> do + username <- x .: "username" + destination <- x .: "destination" + startDate <- x .: "startDate" + endDate <- x .: "endDate" + comment <- x .: "comment" + pure Trip{ tripUsername = username + , tripDestination = destination + , tripStartDate = startDate + , tripEndDate = endDate + , tripComment = comment + } -- | Users and Accounts both refer to the same underlying entities; however, -- Users model the user-facing Account details, hiding sensitive details like @@ -244,8 +288,12 @@ data User = User , userRole :: Role } deriving (Eq, Show, Generic) -instance ToJSON User -instance FromJSON User +instance ToJSON User where + toJSON (User username profilePicture role) = + object [ "username" .= username + , "profilePicture" .= profilePicture + , "role" .= role + ] userFromAccount :: Account -> User userFromAccount account = @@ -253,3 +301,18 @@ userFromAccount account = , userProfilePicture = accountProfilePicture account , userRole = accountRole account } + +-- | This is the data that a user needs to supply to authenticate with the +-- application. +data AccountCredentials = AccountCredentials + { accountCredentialsUsername :: Username + , accountCredentialsPassword :: ClearTextPassword + } deriving (Eq, Show, Generic) + +instance FromJSON AccountCredentials where + parseJSON = withObject "AccountCredentials" $ \x -> do + username <- x.: "username" + password <- x.: "password" + pure AccountCredentials{ accountCredentialsUsername = username + , accountCredentialsPassword = password + } From b170be937532cf976746a50f26b05ff34c4c9c00 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 12:49:16 +0100 Subject: [PATCH 21/79] Hash passwords when creating accounts TL;DR: - introduce the Cryptonite library - Remove the redundant language extensions, imports, deps from Persistent - Prefer NoContent return type for POST /accounts - Define custom {To,From}JSON instances for Role --- shell.nix | 4 +- src/API.hs | 4 +- src/App.hs | 18 +++++---- src/Types.hs | 102 +++++++++++++++++++++++++++++++-------------------- 4 files changed, 76 insertions(+), 52 deletions(-) diff --git a/shell.nix b/shell.nix index 3312fef13..e003737f3 100644 --- a/shell.nix +++ b/shell.nix @@ -8,9 +8,7 @@ in pkgs.mkShell { hpkgs.resource-pool hpkgs.sqlite-simple hpkgs.warp - hpkgs.persistent - hpkgs.persistent-sqlite - hpkgs.persistent-template + hpkgs.cryptonite ])) ]; } diff --git a/src/API.hs b/src/API.hs index 95b9f14a3..134d27842 100644 --- a/src/API.hs +++ b/src/API.hs @@ -12,8 +12,8 @@ import qualified Types as T type API = -- accounts: Create "accounts" - :> ReqBody '[JSON] T.Account - :> Post '[JSON] (Maybe T.Session) + :> ReqBody '[JSON] T.CreateAccountRequest + :> Post '[JSON] NoContent -- accounts: Read -- accounts: Update -- accounts: Delete diff --git a/src/App.hs b/src/App.hs index 8e169f9f8..e9c528ec4 100644 --- a/src/App.hs +++ b/src/App.hs @@ -33,14 +33,16 @@ server dbFile = createAccountH listTripsH = liftIO $ listTrips -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s - createAccount :: T.Account -> IO (Maybe T.Session) - createAccount account = withConnection dbFile $ \conn -> do - execute conn "INSERT INTO Accounts (username,password,email,role,profilePicture) VALUES (?,?,?,?,?)" - (account & T.accountFields) - T.Session{ T.username = T.accountUsername account - , T.password = T.accountPassword account - , T.role = T.accountRole account - } & Just & pure + createAccount :: T.CreateAccountRequest -> IO NoContent + createAccount request = withConnection dbFile $ \conn -> do + hashed <- T.hashPassword (T.createAccountRequestPassword request) + execute conn "INSERT INTO Accounts (username,password,email,role) VALUES (?,?,?,?)" + ( T.createAccountRequestUsername request + , hashed + , T.createAccountRequestEmail request + , T.createAccountRequestRole request + ) + pure NoContent deleteAccount :: Text -> IO NoContent deleteAccount username = withConnection dbFile $ \conn -> do diff --git a/src/Types.hs b/src/Types.hs index 713dd5193..6782b9ec3 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,11 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NamedFieldPuns #-} -------------------------------------------------------------------------------- module Types where @@ -14,14 +9,17 @@ import Data.Aeson import Data.Function ((&)) import Data.Text import Data.Typeable -import Database.Persist.TH import Database.SQLite.Simple import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import GHC.Generics +import Crypto.Random.Types (MonadRandom) +import qualified Crypto.KDF.BCrypt as BC +import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE -------------------------------------------------------------------------------- -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. @@ -43,6 +41,18 @@ instance ToField Username where instance FromField Username where fromField = forNewtype Username +newtype HashedPassword = HashedPassword BS.ByteString + deriving (Eq, Show, Generic) + +instance ToField HashedPassword where + toField (HashedPassword x) = SQLText (TE.decodeUtf8 x) + +instance FromField HashedPassword where + fromField field = + case fieldData field of + (SQLText x) -> x & TE.encodeUtf8 & HashedPassword & Ok + _ -> returnError ConversionFailed field "" + newtype ClearTextPassword = ClearTextPassword Text deriving (Eq, Show, Generic) @@ -70,8 +80,17 @@ instance FromField Email where data Role = RegularUser | Manager | Admin deriving (Eq, Show, Generic) -instance ToJSON Role -instance FromJSON Role +instance ToJSON Role where + toJSON RegularUser = "user" + toJSON Manager = "manager" + toJSON Admin = "admin" + +instance FromJSON Role where + parseJSON = withText "Role" $ \x -> + case x of + "user" -> pure RegularUser + "manager" -> pure Manager + "admin" -> pure Admin instance ToField Role where toField RegularUser = SQLText "user" @@ -101,37 +120,14 @@ instance FromField ProfilePicture where data Account = Account { accountUsername :: Username - , accountPassword :: ClearTextPassword + , accountPassword :: HashedPassword , accountEmail :: Email , accountRole :: Role - , accountProfilePicture :: ProfilePicture + , accountProfilePicture :: Maybe ProfilePicture } deriving (Eq, Show, Generic) -instance ToJSON Account where - toJSON (Account username password email role profilePicture) = - object [ "username" .= username - , "password" .= password - , "email" .= email - , "role" .= role - , "profilePicture" .= profilePicture - ] - -instance FromJSON Account where - parseJSON = withObject "Account" $ \x -> do - username <- x .: "username" - password <- x .: "password" - email <- x .: "email" - role <- x .: "role" - profilePicture <- x .: "profilePicture" - pure Account{ accountUsername = username - , accountPassword = password - , accountEmail = email - , accountRole = role - , accountProfilePicture = profilePicture - } - -- | Return a tuple with all of the fields for an Account record to use for SQL. -accountFields :: Account -> (Username, ClearTextPassword, Email, Role, ProfilePicture) +accountFields :: Account -> (Username, HashedPassword, Email, Role, Maybe ProfilePicture) accountFields (Account { accountUsername , accountPassword , accountEmail @@ -154,14 +150,12 @@ instance FromRow Account where data Session = Session { username :: Username - , password :: ClearTextPassword , role :: Role } deriving (Eq, Show) instance ToJSON Session where - toJSON (Session username password role) = + toJSON (Session username role) = object [ "username" .= username - , "password" .= password , "role" .= role ] @@ -284,7 +278,7 @@ instance FromJSON Trip where -- passwords and emails. data User = User { userUsername :: Username - , userProfilePicture :: ProfilePicture + , userProfilePicture :: Maybe ProfilePicture , userRole :: Role } deriving (Eq, Show, Generic) @@ -316,3 +310,33 @@ instance FromJSON AccountCredentials where pure AccountCredentials{ accountCredentialsUsername = username , accountCredentialsPassword = password } + + +-- -- | Hash password `x`. +hashPassword :: (MonadRandom m) => ClearTextPassword -> m HashedPassword +hashPassword (ClearTextPassword x) = do + hashed <- BC.hashPassword 12 (x & unpack & B.pack) + pure $ HashedPassword hashed + +data CreateAccountRequest = CreateAccountRequest + { createAccountRequestUsername :: Username + , createAccountRequestPassword :: ClearTextPassword + , createAccountRequestEmail :: Email + , createAccountRequestRole :: Role + } deriving (Eq, Show) + +instance FromJSON CreateAccountRequest where + parseJSON = withObject "CreateAccountRequest" $ \x -> do + username <- x .: "username" + password <- x .: "password" + email <- x .: "email" + role <- x .: "role" + pure $ CreateAccountRequest username password email role + +createAccountRequestFields :: CreateAccountRequest -> (Username, ClearTextPassword, Email, Role) +createAccountRequestFields request = + ( createAccountRequestUsername request + , createAccountRequestPassword request + , createAccountRequestEmail request + , createAccountRequestRole request + ) From b3556648582c02fb5a9a10a6a4525e212397f945 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 14:15:41 +0100 Subject: [PATCH 22/79] Support /login Support basic authentication. Note the TODOs that this commit introduces to track some of the remaining work. --- src/API.hs | 5 +++++ src/App.hs | 28 +++++++++++++++++++++++++--- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/src/API.hs b/src/API.hs index 134d27842..9ae618cd3 100644 --- a/src/API.hs +++ b/src/API.hs @@ -37,3 +37,8 @@ type API = -- trips: List :<|> "trips" :> Get '[JSON] [T.Trip] + + -- Miscellaneous + :<|> "login" + :> ReqBody '[JSON] T.AccountCredentials + :> Post '[JSON] (Maybe T.Session) diff --git a/src/App.hs b/src/App.hs index e9c528ec4..f8b81ed98 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,18 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} -------------------------------------------------------------------------------- module App where -------------------------------------------------------------------------------- +import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (runStderrLoggingT) import Data.Function ((&)) import Data.String.Conversions (cs) import Data.Text (Text) import Database.SQLite.Simple import Network.Wai.Handler.Warp as Warp import Servant - import API + +import qualified Crypto.KDF.BCrypt as BC +import qualified Data.Text.Encoding as TE import qualified Types as T -------------------------------------------------------------------------------- @@ -23,14 +27,15 @@ server dbFile = createAccountH :<|> createTripH :<|> deleteTripH :<|> listTripsH + :<|> loginH where createAccountH newUser = liftIO $ createAccount newUser deleteAccountH username = liftIO $ deleteAccount username listAccountsH = liftIO $ listAccounts - createTripH trip = liftIO $ createTrip trip deleteTripH tripPK = liftIO $ deleteTrip tripPK listTripsH = liftIO $ listTrips + loginH creds = liftIO $ login creds -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s createAccount :: T.CreateAccountRequest -> IO NoContent @@ -73,6 +78,23 @@ server dbFile = createAccountH (tripPK & T.tripPKFields) pure NoContent + -- TODO(wpcarro): Create and store a session token + login :: T.AccountCredentials -> IO (Maybe T.Session) + login (T.AccountCredentials username password) = + withConnection dbFile $ \conn -> do + res <- query conn "SELECT * FROM Accounts WHERE username = ?" + (Only username) + case res of + [T.Account{T.accountUsername,T.accountPassword,T.accountRole}] -> + if T.passwordsMatch password accountPassword then + pure $ Just (T.Session accountUsername accountRole) + else + -- TODO(wpcarro): Catch and return errors over HTTP + throwIO $ err401 { errBody = "Your credentials are invalid" } + + -- In this branch, the user didn't supply a known username. + _ -> throwIO $ err401 { errBody = "Your credentials are invalid" } + mkApp :: FilePath -> IO Application mkApp dbFile = do pure $ serve (Proxy @ API) $ server dbFile From 012296f156f59fe8581a01f2ddfd2a1067c09108 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 18:38:30 +0100 Subject: [PATCH 23/79] Move SQL out of API and into separate modules Create modules for each Table in our SQL database. This cleans up the handler bodies at the expense of introducing more files and indirection. --- src/Accounts.hs | 36 ++++++++++++++++++++++++++++++++++++ src/App.hs | 42 +++++++++++++++++------------------------- src/Trips.hs | 27 +++++++++++++++++++++++++++ 3 files changed, 80 insertions(+), 25 deletions(-) create mode 100644 src/Accounts.hs create mode 100644 src/Trips.hs diff --git a/src/Accounts.hs b/src/Accounts.hs new file mode 100644 index 000000000..bdc0bf64d --- /dev/null +++ b/src/Accounts.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Accounts where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +import Database.SQLite.Simple + +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | 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 + hashed <- T.hashPassword password + execute conn "INSERT INTO Accounts (username,password,email,role) VALUES (?,?,?,?)" + (username, hashed, email, role) + +-- | Delete `username` from `dbFile`. +delete :: FilePath -> T.Username -> IO () +delete dbFile username = withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Accounts WHERE username = ?" + (Only username) + +-- | Attempt to find `username` in the Account table of `dbFile`. +lookup :: FilePath -> T.Username -> IO (Maybe T.Account) +lookup dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT * FROM Accounts WHERE username = ?" (Only username) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Return a list of accounts with the sensitive data removed. +list :: FilePath -> IO [T.User] +list dbFile = withConnection dbFile $ \conn -> do + accounts <- query_ conn "SELECT * FROM Accounts" + pure $ T.userFromAccount <$> accounts diff --git a/src/App.hs b/src/App.hs index f8b81ed98..5160f3627 100644 --- a/src/App.hs +++ b/src/App.hs @@ -10,7 +10,6 @@ import Control.Monad.IO.Class (liftIO) import Data.Function ((&)) import Data.String.Conversions (cs) import Data.Text (Text) -import Database.SQLite.Simple import Network.Wai.Handler.Warp as Warp import Servant import API @@ -18,6 +17,8 @@ import API import qualified Crypto.KDF.BCrypt as BC import qualified Data.Text.Encoding as TE import qualified Types as T +import qualified Accounts as Accounts +import qualified Trips as Trips -------------------------------------------------------------------------------- server :: FilePath -> Server API @@ -39,44 +40,35 @@ server dbFile = createAccountH -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s createAccount :: T.CreateAccountRequest -> IO NoContent - createAccount request = withConnection dbFile $ \conn -> do - hashed <- T.hashPassword (T.createAccountRequestPassword request) - execute conn "INSERT INTO Accounts (username,password,email,role) VALUES (?,?,?,?)" - ( T.createAccountRequestUsername request - , hashed - , T.createAccountRequestEmail request - , T.createAccountRequestRole request - ) + createAccount request = do + Accounts.create dbFile + (T.createAccountRequestUsername request) + (T.createAccountRequestPassword request) + (T.createAccountRequestEmail request) + (T.createAccountRequestRole request) pure NoContent deleteAccount :: Text -> IO NoContent - deleteAccount username = withConnection dbFile $ \conn -> do - execute conn "DELETE FROM Accounts WHERE username = ?" - (Only (T.Username username)) + deleteAccount username = do + Accounts.delete dbFile (T.Username username) pure NoContent listAccounts :: IO [T.User] - listAccounts = withConnection dbFile $ \conn -> do - accounts <- query_ conn "SELECT * FROM Accounts" - pure $ T.userFromAccount <$> accounts + listAccounts = Accounts.list dbFile createTrip :: T.Trip -> IO NoContent - createTrip trip = withConnection dbFile $ \conn -> do - execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" - (trip & T.tripFields) + createTrip trip = do + Trips.create dbFile trip pure NoContent listTrips :: IO [T.Trip] - listTrips = withConnection dbFile $ \conn -> - query_ conn "SELECT * FROM Trips" + listTrips = Trips.list dbFile -- TODO(wpcarro): Validate incoming data like startDate. deleteTrip :: T.TripPK -> IO NoContent - deleteTrip tripPK = - withConnection dbFile $ \conn -> do - execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" - (tripPK & T.tripPKFields) - pure NoContent + deleteTrip tripPK = do + Trips.delete dbFile tripPK + pure NoContent -- TODO(wpcarro): Create and store a session token login :: T.AccountCredentials -> IO (Maybe T.Session) diff --git a/src/Trips.hs b/src/Trips.hs new file mode 100644 index 000000000..0b395f8bc --- /dev/null +++ b/src/Trips.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Trips where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +import Database.SQLite.Simple + +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | Create a new `trip` in `dbFile`. +create :: FilePath -> T.Trip -> IO () +create dbFile trip = withConnection dbFile $ \conn -> + execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" + (trip & T.tripFields) + +-- | Delete a trip from `dbFile` using its `tripPK` Primary Key. +delete :: FilePath -> T.TripPK -> IO () +delete dbFile tripPK = + withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" + (tripPK & T.tripPKFields) + +-- | Return a list of all of the trips in `dbFile`. +list :: FilePath -> IO [T.Trip] +list dbFile = withConnection dbFile $ \conn -> + query_ conn "SELECT * FROM Trips" From 36a2fea6863e692d815a513d4b0f15b8c1fcb886 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 18:40:17 +0100 Subject: [PATCH 24/79] Create Sessions table TL;DR: - Create Sessions SQL schema - Create Sessions module - Introduce UUID dependency --- shell.nix | 1 + src/Sessions.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Types.hs | 29 +++++++++++++++++++++ src/init.sql | 13 ++++++++-- 4 files changed, 108 insertions(+), 2 deletions(-) create mode 100644 src/Sessions.hs diff --git a/shell.nix b/shell.nix index e003737f3..8c948e9cb 100644 --- a/shell.nix +++ b/shell.nix @@ -9,6 +9,7 @@ in pkgs.mkShell { hpkgs.sqlite-simple hpkgs.warp hpkgs.cryptonite + hpkgs.uuid ])) ]; } diff --git a/src/Sessions.hs b/src/Sessions.hs new file mode 100644 index 000000000..238a70b6e --- /dev/null +++ b/src/Sessions.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +module Sessions where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +import Database.SQLite.Simple + +import qualified Data.Time.Clock as Clock +import qualified Types as T +import qualified System.Random as Random +-------------------------------------------------------------------------------- + +-- | Return True if `session` was created at most three hours ago. +isValid :: T.StoredSession -> IO Bool +isValid session = do + t1 <- Clock.getCurrentTime + let t0 = T.storedSessionTsCreated session in + pure $ Clock.diffUTCTime t1 t0 <= 3 * 60 * 60 + +-- | Lookup the session stored under `username` in `dbFile`. +find :: FilePath -> T.Username -> IO (Maybe T.StoredSession) +find dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT * FROM Sessions WHERE username = ?" (Only username) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Create a session under the `username` key in `dbFile`. +create :: FilePath -> T.Username -> IO T.SessionUUID +create dbFile username = withConnection dbFile $ \conn -> do + now <- Clock.getCurrentTime + uuid <- Random.randomIO + execute conn "INSERT INTO Sessions (uuid,username,tsCreated) VALUES (?,?,?)" + (T.SessionUUID uuid, username, now) + pure (T.SessionUUID uuid) + +-- | Reset the tsCreated field to the current time to ensure the token is valid. +refresh :: FilePath -> T.SessionUUID -> IO () +refresh dbFile uuid = withConnection dbFile $ \conn -> do + now <- Clock.getCurrentTime + execute conn "UPDATE Sessions SET tsCreated = ? WHERE uuid = ?" + (now, uuid) + pure () + +-- | Delete the session under `username` from `dbFile`. +delete :: FilePath -> T.Username -> IO () +delete dbFile username = withConnection dbFile $ \conn -> + execute conn "DELETE FROM Sessions WHERE username = ?" (Only username) + +-- | Find or create a session in the Sessions table. If a session exists, +-- refresh the token's validity. +findOrCreate :: FilePath -> T.Account -> IO T.SessionUUID +findOrCreate dbFile account = withConnection dbFile $ \conn -> + let username = T.accountUsername account in do + mSession <- find dbFile username + case mSession of + Nothing -> create dbFile username + Just session -> + let uuid = T.storedSessionUUID session in do + refresh dbFile uuid + pure uuid + +-- | Return a list of all sessions in the Sessions table. +list :: FilePath -> IO [T.StoredSession] +list dbFile = withConnection dbFile $ \conn -> + query_ conn "SELECT * FROM Sessions" diff --git a/src/Types.hs b/src/Types.hs index 6782b9ec3..6a474a509 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -17,9 +17,11 @@ import GHC.Generics import Crypto.Random.Types (MonadRandom) import qualified Crypto.KDF.BCrypt as BC +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.UUID as UUID -------------------------------------------------------------------------------- -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. @@ -340,3 +342,30 @@ createAccountRequestFields request = , createAccountRequestEmail request , createAccountRequestRole request ) + +newtype SessionUUID = SessionUUID UUID.UUID + deriving (Eq, Show, Generic) + +instance FromField SessionUUID where + fromField field = + case fieldData field of + (SQLText x) -> + case UUID.fromText x of + Nothing -> returnError ConversionFailed field "" + Just x -> Ok $ SessionUUID x + _ -> returnError ConversionFailed field "" + +instance ToField SessionUUID where + toField (SessionUUID uuid) = + uuid |> UUID.toText |> SQLText + +data StoredSession = StoredSession + { storedSessionUUID :: SessionUUID + , storedSessionUsername :: Username + , storedSessionTsCreated :: Clock.UTCTime + } deriving (Eq, Show, Generic) + +instance FromRow StoredSession where + fromRow = StoredSession <$> field + <*> field + <*> field diff --git a/src/init.sql b/src/init.sql index f1109feac..1439bd338 100644 --- a/src/init.sql +++ b/src/init.sql @@ -8,6 +8,7 @@ BEGIN TRANSACTION; DROP TABLE IF EXISTS Accounts; DROP TABLE IF EXISTS Trips; +DROP TABLE IF EXISTS Sessions; CREATE TABLE Accounts ( -- TODO(wpcarro): Add CHECK(..) constraint @@ -22,11 +23,19 @@ CREATE TABLE Accounts ( CREATE TABLE Trips ( username TEXT NOT NULL, destination TEXT CHECK(LENGTH(destination) > 0) NOT NULL, - startDate TEXT CHECK(LENGTH(startDate) == 10) NOT NULL, -- YYYY-MM-DD - endDate TEXT CHECK(LENGTH(endDate) == 10) NOT NULL, -- YYYY-MM-DD + startDate TEXT CHECK(LENGTH(startDate) == 10) NOT NULL, -- 'YYYY-MM-DD' + endDate TEXT CHECK(LENGTH(endDate) == 10) NOT NULL, -- 'YYYY-MM-DD' comment TEXT NOT NULL, PRIMARY KEY (username, destination, startDate), FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE ); +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' + PRIMARY KEY (uuid), + FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE +); + COMMIT; From 191205acaca88a059a824a2e5e22ab559293a3f1 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 18:42:07 +0100 Subject: [PATCH 25/79] Create populate.sqlite3 to simplify README To make my life easier, I created a small sqlite3 script to populate our database. --- .gitignore | 1 + README.md | 31 +++++++------------------------ populate.sqlite3 | 7 +++++++ 3 files changed, 15 insertions(+), 24 deletions(-) create mode 100644 populate.sqlite3 diff --git a/.gitignore b/.gitignore index aa7648cec..ebea556fe 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.db *.sqlite3 +!populate.sqlite3 *.db-shm *.db-wal \ No newline at end of file diff --git a/README.md b/README.md index 2e5f2f18d..bf81a772b 100644 --- a/README.md +++ b/README.md @@ -34,34 +34,17 @@ Create a new database named `db.sqlite3` with: $ sqlite3 db.sqlite3 ``` -Initialize the schema with: +Populate the database with: ``` -sqlite> .read src/init.sql +sqlite3> .read populate.sqlite3 ``` -You can verify that you successfully initialized the database by running: +You can verify that everything is setup with: ``` -sqlite> .tables -sqlite> .schema Accounts -sqlite> .schema Trips -``` - -Populate the database with some dummy values using the following: - -``` -sqlite> PRAGMA foreign_keys = on; -sqlite> .mode csv -sqlite> .import data/accounts.csv Accounts -sqlite> .import data/trips.csv Trips -``` - -You can verify you successfully populated the tables with: - -``` -sqlite> .mode columns -sqlite> .headers on -sqlite> SELECT * FROM Accounts; -sqlite> SELECT * FROM Trips; +sqlite3> .tables +sqlite3> .schema +sqlite3> SELECT * FROM Accounts; +sqlite3> SELECT * FROM Trips; ``` diff --git a/populate.sqlite3 b/populate.sqlite3 new file mode 100644 index 000000000..e200d2b49 --- /dev/null +++ b/populate.sqlite3 @@ -0,0 +1,7 @@ +PRAGMA foreign_keys = on; +.read src/init.sql +.mode csv +.import data/accounts.csv Accounts +.import data/trips.csv Trips +.mode column +.headers on \ No newline at end of file From 90a521c78f036e024454df39c3e3cd1180c90a74 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 18:46:05 +0100 Subject: [PATCH 26/79] Create Utils module for (|>) operator For the past 3-4 Haskell projects on which I've worked, I've tried to habituate the usage of the (&) operator, but I find that -- as petty as it may sound -- I don't like the way that it looks, and I end up avoiding using it as a result. This time around, I'm aliasing it to (|>) (i.e. Elixir style), and I'm hoping to use it more. --- src/Accounts.hs | 1 - src/App.hs | 2 +- src/Sessions.hs | 1 - src/Trips.hs | 6 +++--- src/Types.hs | 8 ++++---- src/Utils.hs | 8 ++++++++ 6 files changed, 16 insertions(+), 10 deletions(-) create mode 100644 src/Utils.hs diff --git a/src/Accounts.hs b/src/Accounts.hs index bdc0bf64d..c18a599a3 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -2,7 +2,6 @@ -------------------------------------------------------------------------------- module Accounts where -------------------------------------------------------------------------------- -import Data.Function ((&)) import Database.SQLite.Simple import qualified Types as T diff --git a/src/App.hs b/src/App.hs index 5160f3627..929d16520 100644 --- a/src/App.hs +++ b/src/App.hs @@ -7,12 +7,12 @@ module App where -------------------------------------------------------------------------------- import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) -import Data.Function ((&)) import Data.String.Conversions (cs) import Data.Text (Text) import Network.Wai.Handler.Warp as Warp import Servant import API +import Utils import qualified Crypto.KDF.BCrypt as BC import qualified Data.Text.Encoding as TE diff --git a/src/Sessions.hs b/src/Sessions.hs index 238a70b6e..1d3f0d6e8 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -3,7 +3,6 @@ -------------------------------------------------------------------------------- module Sessions where -------------------------------------------------------------------------------- -import Data.Function ((&)) import Database.SQLite.Simple import qualified Data.Time.Clock as Clock diff --git a/src/Trips.hs b/src/Trips.hs index 0b395f8bc..0d805cbe8 100644 --- a/src/Trips.hs +++ b/src/Trips.hs @@ -2,8 +2,8 @@ -------------------------------------------------------------------------------- module Trips where -------------------------------------------------------------------------------- -import Data.Function ((&)) import Database.SQLite.Simple +import Utils import qualified Types as T -------------------------------------------------------------------------------- @@ -12,14 +12,14 @@ import qualified Types as T create :: FilePath -> T.Trip -> IO () create dbFile trip = withConnection dbFile $ \conn -> execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" - (trip & T.tripFields) + (trip |> T.tripFields) -- | Delete a trip from `dbFile` using its `tripPK` Primary Key. delete :: FilePath -> T.TripPK -> IO () delete dbFile tripPK = withConnection dbFile $ \conn -> do execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" - (tripPK & T.tripPKFields) + (tripPK |> T.tripPKFields) -- | Return a list of all of the trips in `dbFile`. list :: FilePath -> IO [T.Trip] diff --git a/src/Types.hs b/src/Types.hs index 6a474a509..96cfae2c2 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -6,7 +6,7 @@ module Types where -------------------------------------------------------------------------------- import Data.Aeson -import Data.Function ((&)) +import Utils import Data.Text import Data.Typeable import Database.SQLite.Simple @@ -52,7 +52,7 @@ instance ToField HashedPassword where instance FromField HashedPassword where fromField field = case fieldData field of - (SQLText x) -> x & TE.encodeUtf8 & HashedPassword & Ok + (SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok _ -> returnError ConversionFailed field "" newtype ClearTextPassword = ClearTextPassword Text @@ -314,10 +314,10 @@ instance FromJSON AccountCredentials where } --- -- | Hash password `x`. +-- | Hash password `x`. hashPassword :: (MonadRandom m) => ClearTextPassword -> m HashedPassword hashPassword (ClearTextPassword x) = do - hashed <- BC.hashPassword 12 (x & unpack & B.pack) + hashed <- BC.hashPassword 12 (x |> unpack |> B.pack) pure $ HashedPassword hashed data CreateAccountRequest = CreateAccountRequest diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 000000000..78ee93ec9 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,8 @@ +-------------------------------------------------------------------------------- +module Utils where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +-------------------------------------------------------------------------------- + +-- | Prefer this operator to the ampersand for stylistic reasons. +(|>) = (&) From f051b0be0bc360c949b3b1913f13c4856ae317ca Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 18:48:38 +0100 Subject: [PATCH 27/79] Check passwords in /login TL;DR: - Since POST /login is more rigorous, our accounts.csv needs to contain validly hashed passwords; you can use tests/create-accounts.sh to create dummy accounts I still need to test the login flow and support: - Tracking failed attempts (three maximum) - Verifying accounts by sending emails to the users --- data/accounts.csv | 6 +++--- src/API.hs | 2 +- src/App.hs | 29 +++++++++++++++-------------- src/Types.hs | 5 +++++ tests/create-accounts.sh | 21 +++++++++++++++++++++ 5 files changed, 45 insertions(+), 18 deletions(-) create mode 100755 tests/create-accounts.sh diff --git a/data/accounts.csv b/data/accounts.csv index 51af23eec..1f8b01582 100644 --- a/data/accounts.csv +++ b/data/accounts.csv @@ -1,3 +1,3 @@ -mimi,testing,miriamwright@google.com,user, -bill,testing,wpcarro@gmail.com,manager, -wpcarro,testing,wpcarro@google.com,admin, \ No newline at end of file +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 9ae618cd3..c84da5aef 100644 --- a/src/API.hs +++ b/src/API.hs @@ -41,4 +41,4 @@ type API = -- Miscellaneous :<|> "login" :> ReqBody '[JSON] T.AccountCredentials - :> Post '[JSON] (Maybe T.Session) + :> Post '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index 929d16520..786820f09 100644 --- a/src/App.hs +++ b/src/App.hs @@ -19,6 +19,7 @@ import qualified Data.Text.Encoding as TE import qualified Types as T import qualified Accounts as Accounts import qualified Trips as Trips +import qualified Sessions as Sessions -------------------------------------------------------------------------------- server :: FilePath -> Server API @@ -71,21 +72,21 @@ server dbFile = createAccountH pure NoContent -- TODO(wpcarro): Create and store a session token - login :: T.AccountCredentials -> IO (Maybe T.Session) - login (T.AccountCredentials username password) = - withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Accounts WHERE username = ?" - (Only username) - case res of - [T.Account{T.accountUsername,T.accountPassword,T.accountRole}] -> - if T.passwordsMatch password accountPassword then - pure $ Just (T.Session accountUsername accountRole) - else - -- TODO(wpcarro): Catch and return errors over HTTP - throwIO $ err401 { errBody = "Your credentials are invalid" } + login :: T.AccountCredentials -> IO NoContent + login (T.AccountCredentials username password) = do + mAccount <- Accounts.lookup dbFile username + case mAccount of + Just account -> + if T.passwordsMatch password (T.accountPassword account) then do + session <- Sessions.findOrCreate dbFile account + -- set cookie + pure NoContent + else + -- TODO(wpcarro): Catch and return errors over HTTP + throwIO $ err401 { errBody = "Your credentials are invalid" } - -- In this branch, the user didn't supply a known username. - _ -> throwIO $ err401 { errBody = "Your credentials are invalid" } + -- In this branch, the user didn't supply a known username. + Nothing -> throwIO $ err401 { errBody = "Your credentials are invalid" } mkApp :: FilePath -> IO Application mkApp dbFile = do diff --git a/src/Types.hs b/src/Types.hs index 96cfae2c2..25f7d8996 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -320,6 +320,11 @@ hashPassword (ClearTextPassword x) = do hashed <- BC.hashPassword 12 (x |> unpack |> B.pack) pure $ HashedPassword hashed +-- | Return True if the cleartext password matches the hashed password. +passwordsMatch :: ClearTextPassword -> HashedPassword -> Bool +passwordsMatch (ClearTextPassword clear) (HashedPassword hashed) = + BC.validatePassword (clear |> unpack |> B.pack) hashed + data CreateAccountRequest = CreateAccountRequest { createAccountRequestUsername :: Username , createAccountRequestPassword :: ClearTextPassword diff --git a/tests/create-accounts.sh b/tests/create-accounts.sh new file mode 100755 index 000000000..8c2a66bc8 --- /dev/null +++ b/tests/create-accounts.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env sh + +# This script populates the Accounts table over HTTP. + +http POST :3000/accounts \ + username=mimi \ + password=testing \ + email=miriamwright@google.com \ + role=user + +http POST :3000/accounts \ + username=bill \ + password=testing \ + email=wpcarro@gmail.com \ + role=manager + +http POST :3000/accounts \ + username=wpcarro \ + password=testing \ + email=wpcarro@google.com \ + role=admin From cf6c8799ab86278c827d4236a7a89163c61c29b9 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 28 Jul 2020 21:33:58 +0100 Subject: [PATCH 28/79] Restrict users from multiple failed login attempts I'm not resetting the failed LoginAttempt count, which is a low priority for now, but necessary eventually. --- src/App.hs | 33 +++++++++++++++++++++++++-------- src/LoginAttempts.hs | 29 +++++++++++++++++++++++++++++ src/Types.hs | 8 ++++++++ src/init.sql | 8 ++++++++ 4 files changed, 70 insertions(+), 8 deletions(-) create mode 100644 src/LoginAttempts.hs diff --git a/src/App.hs b/src/App.hs index 786820f09..209e2f209 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -------------------------------------------------------------------------------- module App where @@ -20,6 +21,7 @@ import qualified Types as T import qualified Accounts as Accounts import qualified Trips as Trips import qualified Sessions as Sessions +import qualified LoginAttempts as LoginAttempts -------------------------------------------------------------------------------- server :: FilePath -> Server API @@ -76,14 +78,29 @@ server dbFile = createAccountH login (T.AccountCredentials username password) = do mAccount <- Accounts.lookup dbFile username case mAccount of - Just account -> - if T.passwordsMatch password (T.accountPassword account) then do - session <- Sessions.findOrCreate dbFile account - -- set cookie - pure NoContent - else - -- TODO(wpcarro): Catch and return errors over HTTP - throwIO $ err401 { errBody = "Your credentials are invalid" } + Just account@T.Account{..} -> do + mAttempts <- LoginAttempts.forUsername dbFile accountUsername + case mAttempts of + Nothing -> + if T.passwordsMatch password accountPassword then do + session <- Sessions.findOrCreate dbFile account + -- set cookie + pure NoContent + else do + LoginAttempts.increment dbFile username + throwIO $ err401 { errBody = "Your credentials are invalid" } + Just attempts -> + if attempts > 3 then + -- TODO(wpcarro): Prefer 429 error code + throwIO $ err401 { errBody = "Too many failed login attempts" } + else if T.passwordsMatch password accountPassword then do + session <- Sessions.findOrCreate dbFile account + -- set cookie + pure NoContent + else do + LoginAttempts.increment dbFile username + -- TODO(wpcarro): Catch and return errors over HTTP + throwIO $ err401 { errBody = "Your credentials are invalid" } -- In this branch, the user didn't supply a known username. Nothing -> throwIO $ err401 { errBody = "Your credentials are invalid" } diff --git a/src/LoginAttempts.hs b/src/LoginAttempts.hs new file mode 100644 index 000000000..a7e950da7 --- /dev/null +++ b/src/LoginAttempts.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module LoginAttempts where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple + +import qualified Types as T +-------------------------------------------------------------------------------- + +reset :: FilePath -> T.Username -> IO () +reset dbFile username = withConnection dbFile $ \conn -> + execute conn "UPDATE LoginAttempts SET numAttempts = 0 WHERE username = ?" + (Only username) + +-- | Attempt to return the number of failed login attempts for +-- `username`. Returns a Maybe in case `username` doesn't exist. +forUsername :: FilePath -> T.Username -> IO (Maybe Integer) +forUsername dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT (numAttempts) FROM LoginAttempts WHERE username = ?" + (Only username) + case res of + [T.LoginAttempt{..}] -> pure (Just loginAttemptNumAttempts) + _ -> pure Nothing + +increment :: FilePath -> T.Username -> IO () +increment dbFile username = withConnection dbFile $ \conn -> + execute conn "UPDATE LoginAttempts SET numAttempts = numAttempts + 1 WHERE username = ?" + (Only username) diff --git a/src/Types.hs b/src/Types.hs index 25f7d8996..d33ea6870 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -374,3 +374,11 @@ instance FromRow StoredSession where fromRow = StoredSession <$> field <*> field <*> field + +data LoginAttempt = LoginAttempt + { loginAttemptUsername :: Username + , loginAttemptNumAttempts :: Integer + } deriving (Eq, Show) + +instance FromRow LoginAttempt where + fromRow = LoginAttempt <$> field <*> field diff --git a/src/init.sql b/src/init.sql index 1439bd338..117a3bd06 100644 --- a/src/init.sql +++ b/src/init.sql @@ -9,6 +9,7 @@ BEGIN TRANSACTION; DROP TABLE IF EXISTS Accounts; DROP TABLE IF EXISTS Trips; DROP TABLE IF EXISTS Sessions; +DROP TABLE IF EXISTS LoginAttempts; CREATE TABLE Accounts ( -- TODO(wpcarro): Add CHECK(..) constraint @@ -38,4 +39,11 @@ CREATE TABLE Sessions ( FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE ); +CREATE TABLE LoginAttempts ( + username TEXT NOT NULL UNIQUE, + numAttempts INTEGER NOT NULL, + PRIMARY KEY (username), + FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE +); + COMMIT; From 289cae2528946aa5d745e904cdaaec7df1a71493 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Wed, 29 Jul 2020 09:51:18 +0100 Subject: [PATCH 29/79] Add Elm boilerplate to project Create a top-level client directory to store my Elm boilerplate. --- client/.gitignore | 3 +++ client/README.md | 17 +++++++++++++++++ client/dir-locals.nix | 3 +++ client/elm.json | 30 +++++++++++++++++++++++++++++ client/index.css | 3 +++ client/index.html | 15 +++++++++++++++ client/shell.nix | 9 +++++++++ client/src/Landing.elm | 13 +++++++++++++ client/src/Login.elm | 13 +++++++++++++ client/src/Main.elm | 31 ++++++++++++++++++++++++++++++ client/src/State.elm | 43 ++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 180 insertions(+) create mode 100644 client/.gitignore create mode 100644 client/README.md create mode 100644 client/dir-locals.nix create mode 100644 client/elm.json create mode 100644 client/index.css create mode 100644 client/index.html create mode 100644 client/shell.nix create mode 100644 client/src/Landing.elm create mode 100644 client/src/Login.elm create mode 100644 client/src/Main.elm create mode 100644 client/src/State.elm diff --git a/client/.gitignore b/client/.gitignore new file mode 100644 index 000000000..1cb4f3034 --- /dev/null +++ b/client/.gitignore @@ -0,0 +1,3 @@ +/elm-stuff +/Main.min.js +/output.css diff --git a/client/README.md b/client/README.md new file mode 100644 index 000000000..425d5163e --- /dev/null +++ b/client/README.md @@ -0,0 +1,17 @@ +# Elm + +Elm has one of the best developer experiences that I'm aware of. The error +messages are helpful and the entire experience is optimized to improve the ease +of writing web applications. + +## Developing + +If you're interested in contributing, the following will create an environment +in which you can develop: + +```shell +$ nix-shell +$ elm-live -- src/Main.elm --output=Main.min.js +``` + +You can now view your web client at `http://localhost:8000`! diff --git a/client/dir-locals.nix b/client/dir-locals.nix new file mode 100644 index 000000000..498f4b505 --- /dev/null +++ b/client/dir-locals.nix @@ -0,0 +1,3 @@ +let + briefcase = import {}; +in briefcase.utils.nixBufferFromShell ./shell.nix diff --git a/client/elm.json b/client/elm.json new file mode 100644 index 000000000..a95f80408 --- /dev/null +++ b/client/elm.json @@ -0,0 +1,30 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "elm/browser": "1.0.2", + "elm/core": "1.0.5", + "elm/html": "1.0.0", + "elm/random": "1.0.0", + "elm/svg": "1.0.1", + "elm/time": "1.0.0", + "elm-community/list-extra": "8.2.3", + "elm-community/maybe-extra": "5.2.0", + "elm-community/random-extra": "3.1.0" + }, + "indirect": { + "elm/json": "1.1.3", + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.2", + "owanturist/elm-union-find": "1.0.0" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} diff --git a/client/index.css b/client/index.css new file mode 100644 index 000000000..b5c61c956 --- /dev/null +++ b/client/index.css @@ -0,0 +1,3 @@ +@tailwind base; +@tailwind components; +@tailwind utilities; diff --git a/client/index.html b/client/index.html new file mode 100644 index 000000000..ce8f727b6 --- /dev/null +++ b/client/index.html @@ -0,0 +1,15 @@ + + + + + Elm SPA + + + + +
+ + + diff --git a/client/shell.nix b/client/shell.nix new file mode 100644 index 000000000..6f1c8ee23 --- /dev/null +++ b/client/shell.nix @@ -0,0 +1,9 @@ +let + pkgs = import {}; +in pkgs.mkShell { + buildInputs = with pkgs; [ + elmPackages.elm + elmPackages.elm-format + elmPackages.elm-live + ]; +} diff --git a/client/src/Landing.elm b/client/src/Landing.elm new file mode 100644 index 000000000..00bb9e281 --- /dev/null +++ b/client/src/Landing.elm @@ -0,0 +1,13 @@ +module Landing exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import State + + +render : State.Model -> Html State.Msg +render model = + div [ class "pt-10 pb-20 px-10" ] + [ p [] [ text "Welcome to the landing page!" ] + ] diff --git a/client/src/Login.elm b/client/src/Login.elm new file mode 100644 index 000000000..27f1d811a --- /dev/null +++ b/client/src/Login.elm @@ -0,0 +1,13 @@ +module Login exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import State + + +render : State.Model -> Html State.Msg +render model = + div [ class "pt-10 pb-20 px-10" ] + [ p [] [ text "Please authenticate" ] + ] diff --git a/client/src/Main.elm b/client/src/Main.elm new file mode 100644 index 000000000..30006460c --- /dev/null +++ b/client/src/Main.elm @@ -0,0 +1,31 @@ +module Main exposing (main) + +import Browser +import Html exposing (..) +import Landing +import Login +import State + + +subscriptions : State.Model -> Sub State.Msg +subscriptions model = + Sub.none + + +view : State.Model -> Html State.Msg +view model = + case model.view of + State.Landing -> + Landing.render model + + State.Login -> + Login.render model + + +main = + Browser.element + { init = \() -> ( State.init, Cmd.none ) + , subscriptions = subscriptions + , update = State.update + , view = view + } diff --git a/client/src/State.elm b/client/src/State.elm new file mode 100644 index 000000000..c1edae8bb --- /dev/null +++ b/client/src/State.elm @@ -0,0 +1,43 @@ +module State exposing (..) + + +type Msg + = DoNothing + | SetView View + + +type View + = Landing + | Login + + +type alias Model = + { isLoading : Bool + , view : View + } + + +{-| The initial state for the application. +-} +init : Model +init = + { isLoading = False + , view = Landing + } + + +{-| Now that we have state, we need a function to change the state. +-} +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + DoNothing -> + ( model, Cmd.none ) + + SetView x -> + ( { model + | view = x + , isLoading = True + } + , Cmd.none + ) From 9f70cb2c612212e218b5df75c9afba08f51d3acb Mon Sep 17 00:00:00 2001 From: William Carroll Date: Wed, 29 Jul 2020 10:13:19 +0100 Subject: [PATCH 30/79] Add boilerplate for Google sign-in For more information, read: https://developers.google.com/identity/sign-in/web/sign-in?authuser=1 TODO: Use Elm ports or something similar to properly interop with the onSignIn and signOn functions defined in index.html. --- client/index.html | 18 ++++++++++++++++++ client/src/Login.elm | 5 ++++- client/src/State.elm | 2 +- 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/client/index.html b/client/index.html index ce8f727b6..facf4e986 100644 --- a/client/index.html +++ b/client/index.html @@ -2,13 +2,31 @@ + Elm SPA +
diff --git a/client/src/Login.elm b/client/src/Login.elm index 27f1d811a..968325d48 100644 --- a/client/src/Login.elm +++ b/client/src/Login.elm @@ -5,9 +5,12 @@ import Html.Attributes exposing (..) import Html.Events exposing (..) import State +googleSignIn : Html State.Msg +googleSignIn = + div [ class "g-signin2", attribute "onsuccess" "onSignIn" ] [] render : State.Model -> Html State.Msg render model = div [ class "pt-10 pb-20 px-10" ] - [ p [] [ text "Please authenticate" ] + [ googleSignIn ] diff --git a/client/src/State.elm b/client/src/State.elm index c1edae8bb..8c56a7ecc 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -22,7 +22,7 @@ type alias Model = init : Model init = { isLoading = False - , view = Landing + , view = Login } From c4a090e55803864c21e8c40432ca17772247ca8e Mon Sep 17 00:00:00 2001 From: William Carroll Date: Wed, 29 Jul 2020 14:14:47 +0100 Subject: [PATCH 31/79] Support reading / writing cookies in API Update my API type and handler types to reflect which handlers read and write cookies. TODO: - Actually read from and write to Set-Cookie header - Returning `pure NoContent` breaks my types, so I'm returning `undefined` now --- src/API.hs | 13 ++++++++++- src/App.hs | 64 ++++++++++++++++++++++++++++++---------------------- src/Types.hs | 10 ++++++++ 3 files changed, 59 insertions(+), 28 deletions(-) diff --git a/src/API.hs b/src/API.hs index c84da5aef..50263bb3e 100644 --- a/src/API.hs +++ b/src/API.hs @@ -5,10 +5,14 @@ module API where -------------------------------------------------------------------------------- import Data.Text import Servant.API +import Web.Cookie import qualified Types as T -------------------------------------------------------------------------------- +-- | Once authenticated, users receive a SessionCookie. +type SessionCookie = Header' '[Required] "Set-Cookie" T.SessionCookie + type API = -- accounts: Create "accounts" @@ -18,20 +22,24 @@ type API = -- accounts: Update -- accounts: Delete :<|> "accounts" + :> SessionCookie :> QueryParam' '[Required] "username" Text :> Delete '[JSON] NoContent -- accounts: List :<|> "accounts" + :> SessionCookie :> Get '[JSON] [T.User] -- trips: Create :<|> "trips" + :> SessionCookie :> ReqBody '[JSON] T.Trip :> Post '[JSON] NoContent -- trips: Read -- trips: Update -- trips: Delete :<|> "trips" + :> SessionCookie :> ReqBody '[JSON] T.TripPK :> Delete '[JSON] NoContent -- trips: List @@ -41,4 +49,7 @@ type API = -- Miscellaneous :<|> "login" :> ReqBody '[JSON] T.AccountCredentials - :> Post '[JSON] NoContent + :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) + :<|> "logout" + :> SessionCookie + :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) diff --git a/src/App.hs b/src/App.hs index 209e2f209..783b4402f 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} @@ -14,6 +15,7 @@ import Network.Wai.Handler.Warp as Warp import Servant import API import Utils +import Web.Cookie import qualified Crypto.KDF.BCrypt as BC import qualified Data.Text.Encoding as TE @@ -32,14 +34,16 @@ server dbFile = createAccountH :<|> deleteTripH :<|> listTripsH :<|> loginH + :<|> logoutH where - createAccountH newUser = liftIO $ createAccount newUser - deleteAccountH username = liftIO $ deleteAccount username - listAccountsH = liftIO $ listAccounts - createTripH trip = liftIO $ createTrip trip - deleteTripH tripPK = liftIO $ deleteTrip tripPK - listTripsH = liftIO $ listTrips - loginH creds = liftIO $ login creds + createAccountH newUser = liftIO $ createAccount newUser + deleteAccountH cookie username = liftIO $ deleteAccount cookie username + listAccountsH cookie = liftIO $ listAccounts cookie + createTripH cookie trip = liftIO $ createTrip cookie trip + deleteTripH cookie tripPK = liftIO $ deleteTrip cookie tripPK + listTripsH = liftIO $ listTrips + loginH creds = liftIO $ login creds + logoutH cookie = liftIO $ logout cookie -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s createAccount :: T.CreateAccountRequest -> IO NoContent @@ -51,30 +55,30 @@ server dbFile = createAccountH (T.createAccountRequestRole request) pure NoContent - deleteAccount :: Text -> IO NoContent - deleteAccount username = do + deleteAccount :: T.SessionCookie -> Text -> IO NoContent + deleteAccount cookie username = do Accounts.delete dbFile (T.Username username) pure NoContent - listAccounts :: IO [T.User] - listAccounts = Accounts.list dbFile + listAccounts :: T.SessionCookie -> IO [T.User] + listAccounts cookie = Accounts.list dbFile - createTrip :: T.Trip -> IO NoContent - createTrip trip = do + createTrip :: T.SessionCookie -> T.Trip -> IO NoContent + createTrip cookie trip = do Trips.create dbFile trip pure NoContent + -- TODO(wpcarro): Validate incoming data like startDate. + deleteTrip :: T.SessionCookie -> T.TripPK -> IO NoContent + deleteTrip cookie tripPK = do + Trips.delete dbFile tripPK + pure NoContent + listTrips :: IO [T.Trip] listTrips = Trips.list dbFile - -- TODO(wpcarro): Validate incoming data like startDate. - deleteTrip :: T.TripPK -> IO NoContent - deleteTrip tripPK = do - Trips.delete dbFile tripPK - pure NoContent - - -- TODO(wpcarro): Create and store a session token - login :: T.AccountCredentials -> IO NoContent + login :: T.AccountCredentials + -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent) login (T.AccountCredentials username password) = do mAccount <- Accounts.lookup dbFile username case mAccount of @@ -85,25 +89,31 @@ server dbFile = createAccountH if T.passwordsMatch password accountPassword then do session <- Sessions.findOrCreate dbFile account -- set cookie - pure NoContent + undefined else do LoginAttempts.increment dbFile username - throwIO $ err401 { errBody = "Your credentials are invalid" } + throwIO err401 { errBody = "Your credentials are invalid" } Just attempts -> if attempts > 3 then -- TODO(wpcarro): Prefer 429 error code - throwIO $ err401 { errBody = "Too many failed login attempts" } + throwIO err401 { errBody = "Too many failed login attempts" } else if T.passwordsMatch password accountPassword then do session <- Sessions.findOrCreate dbFile account -- set cookie - pure NoContent + undefined else do LoginAttempts.increment dbFile username -- TODO(wpcarro): Catch and return errors over HTTP - throwIO $ err401 { errBody = "Your credentials are invalid" } + throwIO err401 { errBody = "Your credentials are invalid" } -- In this branch, the user didn't supply a known username. - Nothing -> throwIO $ err401 { errBody = "Your credentials are invalid" } + Nothing -> throwIO err401 { errBody = "Your credentials are invalid" } + + logout :: T.SessionCookie + -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent) + logout cookie = undefined + -- pull off SessionUUID from the request headers + -- delete the SessionUUID from the Sessions table. mkApp :: FilePath -> IO Application mkApp dbFile = do diff --git a/src/Types.hs b/src/Types.hs index d33ea6870..eed9bf8c1 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -14,6 +14,8 @@ import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import GHC.Generics +import Web.Cookie +import Servant.API import Crypto.Random.Types (MonadRandom) import qualified Crypto.KDF.BCrypt as BC @@ -382,3 +384,11 @@ data LoginAttempt = LoginAttempt instance FromRow LoginAttempt where fromRow = LoginAttempt <$> field <*> field + +newtype SessionCookie = SessionCookie Cookies + +instance FromHttpApiData SessionCookie where + parseHeader x = + x |> parseCookies |> SessionCookie |> pure + parseQueryParam x = + x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure From 16f50e33bc20cfd1010d22c8533c0e6666a41f4c Mon Sep 17 00:00:00 2001 From: William Carroll Date: Wed, 29 Jul 2020 20:21:29 +0100 Subject: [PATCH 32/79] Prefer deleting sessions by their UUID Instead of deleting them by usernames. --- src/Sessions.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Sessions.hs b/src/Sessions.hs index 1d3f0d6e8..12b641b92 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -43,9 +43,9 @@ refresh dbFile uuid = withConnection dbFile $ \conn -> do pure () -- | Delete the session under `username` from `dbFile`. -delete :: FilePath -> T.Username -> IO () -delete dbFile username = withConnection dbFile $ \conn -> - execute conn "DELETE FROM Sessions WHERE username = ?" (Only username) +delete :: FilePath -> T.SessionUUID -> IO () +delete dbFile uuid = withConnection dbFile $ \conn -> + execute conn "DELETE FROM Sessions WHERE uuid = ?" (Only uuid) -- | Find or create a session in the Sessions table. If a session exists, -- refresh the token's validity. From ab12be784068c19f3e8dd00494b83a510c602e9c Mon Sep 17 00:00:00 2001 From: William Carroll Date: Wed, 29 Jul 2020 20:21:56 +0100 Subject: [PATCH 33/79] Support looking up a session by its UUID We need to read a session from the session table using its UUID. --- src/Sessions.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Sessions.hs b/src/Sessions.hs index 12b641b92..b03de6eee 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -17,6 +17,14 @@ isValid session = do let t0 = T.storedSessionTsCreated session in pure $ Clock.diffUTCTime t1 t0 <= 3 * 60 * 60 +-- | Lookup the session by UUID. +get :: FilePath -> T.SessionUUID -> IO (Maybe T.StoredSession) +get dbFile uuid = withConnection dbFile $ \conn -> do + res <- query conn "SELECT * FROM Session WHERE uuid = ?" (Only uuid) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + -- | Lookup the session stored under `username` in `dbFile`. find :: FilePath -> T.Username -> IO (Maybe T.StoredSession) find dbFile username = withConnection dbFile $ \conn -> do From fdd51f626c46780c22edf7841fe95a3bdaff699b Mon Sep 17 00:00:00 2001 From: William Carroll Date: Wed, 29 Jul 2020 20:26:23 +0100 Subject: [PATCH 34/79] Fully support login, logout Refactor my handlers to use the `Handler a` type instead of `IO a`; this allows me to throwError inside of handlers that Servant properly handles. Previously I was creating 500 errors unnecessarily. --- src/API.hs | 2 +- src/App.hs | 121 +++++++++++++++++++++++++++------------------------- src/Auth.hs | 54 +++++++++++++++++++++++ 3 files changed, 117 insertions(+), 60 deletions(-) create mode 100644 src/Auth.hs diff --git a/src/API.hs b/src/API.hs index 50263bb3e..01f7b7b75 100644 --- a/src/API.hs +++ b/src/API.hs @@ -11,7 +11,7 @@ import qualified Types as T -------------------------------------------------------------------------------- -- | Once authenticated, users receive a SessionCookie. -type SessionCookie = Header' '[Required] "Set-Cookie" T.SessionCookie +type SessionCookie = Header' '[Required] "Cookie" T.SessionCookie type API = -- accounts: Create diff --git a/src/App.hs b/src/App.hs index 783b4402f..4d9bf22db 100644 --- a/src/App.hs +++ b/src/App.hs @@ -7,118 +7,121 @@ -------------------------------------------------------------------------------- module App where -------------------------------------------------------------------------------- -import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) import Data.String.Conversions (cs) import Data.Text (Text) import Network.Wai.Handler.Warp as Warp import Servant +import Servant.Server.Internal.ServerError import API import Utils import Web.Cookie import qualified Crypto.KDF.BCrypt as BC import qualified Data.Text.Encoding as TE +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID import qualified Types as T import qualified Accounts as Accounts +import qualified Auth as Auth import qualified Trips as Trips import qualified Sessions as Sessions import qualified LoginAttempts as LoginAttempts -------------------------------------------------------------------------------- -server :: FilePath -> Server API -server dbFile = createAccountH - :<|> deleteAccountH - :<|> listAccountsH - :<|> createTripH - :<|> deleteTripH - :<|> listTripsH - :<|> loginH - :<|> logoutH - where - createAccountH newUser = liftIO $ createAccount newUser - deleteAccountH cookie username = liftIO $ deleteAccount cookie username - listAccountsH cookie = liftIO $ listAccounts cookie - createTripH cookie trip = liftIO $ createTrip cookie trip - deleteTripH cookie tripPK = liftIO $ deleteTrip cookie tripPK - listTripsH = liftIO $ listTrips - loginH creds = liftIO $ login creds - logoutH cookie = liftIO $ logout cookie +err429 :: ServerError +err429 = ServerError + { errHTTPCode = 429 + , errReasonPhrase = "Too many requests" + , errBody = "" + , errHeaders = [] + } +server :: FilePath -> Server API +server dbFile = createAccount + :<|> deleteAccount + :<|> listAccounts + :<|> createTrip + :<|> deleteTrip + :<|> listTrips + :<|> login + :<|> logout + where -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s - createAccount :: T.CreateAccountRequest -> IO NoContent + createAccount :: T.CreateAccountRequest -> Handler NoContent createAccount request = do - Accounts.create dbFile + liftIO $ Accounts.create dbFile (T.createAccountRequestUsername request) (T.createAccountRequestPassword request) (T.createAccountRequestEmail request) (T.createAccountRequestRole request) pure NoContent - deleteAccount :: T.SessionCookie -> Text -> IO NoContent + deleteAccount :: T.SessionCookie -> Text -> Handler NoContent deleteAccount cookie username = do - Accounts.delete dbFile (T.Username username) - pure NoContent + mRole <- liftIO $ Auth.roleFromCookie dbFile cookie + case mRole of + Just T.Admin -> do + liftIO $ Accounts.delete dbFile (T.Username username) + pure NoContent + -- cannot delete an account if you're not an Admin + _ -> throwError err401 { errBody = "Only admins can delete accounts." } - listAccounts :: T.SessionCookie -> IO [T.User] - listAccounts cookie = Accounts.list dbFile + listAccounts :: T.SessionCookie -> Handler [T.User] + listAccounts (T.SessionCookie cookie) = liftIO $ Accounts.list dbFile - createTrip :: T.SessionCookie -> T.Trip -> IO NoContent + createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent createTrip cookie trip = do - Trips.create dbFile trip + liftIO $ Trips.create dbFile trip pure NoContent -- TODO(wpcarro): Validate incoming data like startDate. - deleteTrip :: T.SessionCookie -> T.TripPK -> IO NoContent + deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent deleteTrip cookie tripPK = do - Trips.delete dbFile tripPK + liftIO $ Trips.delete dbFile tripPK pure NoContent - listTrips :: IO [T.Trip] - listTrips = Trips.list dbFile + listTrips :: Handler [T.Trip] + listTrips = liftIO $ Trips.list dbFile login :: T.AccountCredentials - -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent) + -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent) login (T.AccountCredentials username password) = do - mAccount <- Accounts.lookup dbFile username + mAccount <- liftIO $ Accounts.lookup dbFile username case mAccount of Just account@T.Account{..} -> do - mAttempts <- LoginAttempts.forUsername dbFile accountUsername + mAttempts <- liftIO $ LoginAttempts.forUsername dbFile accountUsername case mAttempts of Nothing -> if T.passwordsMatch password accountPassword then do - session <- Sessions.findOrCreate dbFile account - -- set cookie - undefined + uuid <- liftIO $ Sessions.findOrCreate dbFile account + pure $ addHeader (Auth.mkCookie uuid) NoContent else do - LoginAttempts.increment dbFile username - throwIO err401 { errBody = "Your credentials are invalid" } + liftIO $ LoginAttempts.increment dbFile username + throwError err401 { errBody = "Your credentials are invalid" } Just attempts -> if attempts > 3 then - -- TODO(wpcarro): Prefer 429 error code - throwIO err401 { errBody = "Too many failed login attempts" } + throwError err429 else if T.passwordsMatch password accountPassword then do - session <- Sessions.findOrCreate dbFile account - -- set cookie - undefined + uuid <- liftIO $ Sessions.findOrCreate dbFile account + pure $ addHeader (Auth.mkCookie uuid) NoContent else do - LoginAttempts.increment dbFile username - -- TODO(wpcarro): Catch and return errors over HTTP - throwIO err401 { errBody = "Your credentials are invalid" } + liftIO $ LoginAttempts.increment dbFile username + throwError err401 { errBody = "Your credentials are invalid" } -- In this branch, the user didn't supply a known username. - Nothing -> throwIO err401 { errBody = "Your credentials are invalid" } + Nothing -> throwError err401 { errBody = "Your credentials are invalid" } logout :: T.SessionCookie - -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent) - logout cookie = undefined - -- pull off SessionUUID from the request headers - -- delete the SessionUUID from the Sessions table. - -mkApp :: FilePath -> IO Application -mkApp dbFile = do - pure $ serve (Proxy @ API) $ server dbFile + -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent) + logout cookie = do + case Auth.uuidFromCookie cookie of + Nothing -> + pure $ addHeader Auth.emptyCookie NoContent + Just uuid -> do + liftIO $ Sessions.delete dbFile uuid + pure $ addHeader Auth.emptyCookie NoContent run :: FilePath -> IO () -run sqliteFile = - Warp.run 3000 =<< mkApp sqliteFile +run dbFile = + Warp.run 3000 (serve (Proxy @ API) $ server dbFile) diff --git a/src/Auth.hs b/src/Auth.hs new file mode 100644 index 000000000..6a2436058 --- /dev/null +++ b/src/Auth.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Auth where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple +import Utils +import Web.Cookie + +import qualified Data.UUID as UUID +import qualified Web.Cookie as WC +import qualified Sessions as Sessions +import qualified Accounts as Accounts +import qualified Types as T +import qualified Data.ByteString.Lazy as LBS +-------------------------------------------------------------------------------- + +-- | Return the UUID from a Session cookie. +uuidFromCookie :: T.SessionCookie -> Maybe T.SessionUUID +uuidFromCookie (T.SessionCookie cookies) = do + auth <- lookup "auth" cookies + uuid <- UUID.fromASCIIBytes auth + pure $ T.SessionUUID uuid + +-- | Attempt to return the user role associated with the `cookie`. +roleFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Role) +roleFromCookie dbFile cookie = withConnection dbFile $ \conn -> do + case uuidFromCookie cookie of + Nothing -> pure Nothing + Just uuid -> do + mSession <- Sessions.get dbFile uuid + case mSession of + Nothing -> pure Nothing + Just T.StoredSession{..} -> do + mAccount <- Accounts.lookup dbFile storedSessionUsername + case mAccount of + Nothing -> pure Nothing + Just T.Account{..} -> pure (Just accountRole) + +-- | Create a new session cookie. +mkCookie :: T.SessionUUID -> SetCookie +mkCookie (T.SessionUUID uuid) = + defaultSetCookie + { setCookieName = "auth" + , setCookieValue = UUID.toASCIIBytes uuid + } + +-- | Use this to clear out the session cookie. +emptyCookie :: SetCookie +emptyCookie = + defaultSetCookie + { setCookieName = "auth" + , setCookieValue = "" + } From ca26fcd523e8744b7ca81cd275a60aa2618230a0 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 09:51:32 +0100 Subject: [PATCH 35/79] Debug erroneous table name "Session" doesn't exist, but "Sessions" does. --- src/Sessions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Sessions.hs b/src/Sessions.hs index b03de6eee..19099fe2e 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -20,7 +20,7 @@ isValid session = do -- | Lookup the session by UUID. get :: FilePath -> T.SessionUUID -> IO (Maybe T.StoredSession) get dbFile uuid = withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Session WHERE uuid = ?" (Only uuid) + res <- query conn "SELECT * FROM Sessions WHERE uuid = ?" (Only uuid) case res of [x] -> pure (Just x) _ -> pure Nothing From 385164c6afea7995b797cf8ddddefa187c26f646 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 10:23:55 +0100 Subject: [PATCH 36/79] Authorize endpoints If I ever fully learn `servant-auth`, I'll probably recognize how naive this hand-rolled solution is. But it works! And the code is pretty declarative, which I like. --- src/App.hs | 36 +++++++++++++++++++----------------- src/Auth.hs | 24 ++++++++++++++++++++---- 2 files changed, 39 insertions(+), 21 deletions(-) diff --git a/src/App.hs b/src/App.hs index 4d9bf22db..708dd896f 100644 --- a/src/App.hs +++ b/src/App.hs @@ -47,6 +47,11 @@ server dbFile = createAccount :<|> login :<|> logout where + -- Admit Admins + whatever the predicate `p` passes. + adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) + -- Admit Admins only. + adminsOnly cookie = adminsAnd cookie (const True) + -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s createAccount :: T.CreateAccountRequest -> Handler NoContent createAccount request = do @@ -58,26 +63,23 @@ server dbFile = createAccount pure NoContent deleteAccount :: T.SessionCookie -> Text -> Handler NoContent - deleteAccount cookie username = do - mRole <- liftIO $ Auth.roleFromCookie dbFile cookie - case mRole of - Just T.Admin -> do - liftIO $ Accounts.delete dbFile (T.Username username) - pure NoContent - -- cannot delete an account if you're not an Admin - _ -> throwError err401 { errBody = "Only admins can delete accounts." } - - listAccounts :: T.SessionCookie -> Handler [T.User] - listAccounts (T.SessionCookie cookie) = liftIO $ Accounts.list dbFile - - createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent - createTrip cookie trip = do - liftIO $ Trips.create dbFile trip + deleteAccount cookie username = adminsOnly cookie $ do + liftIO $ Accounts.delete dbFile (T.Username username) pure NoContent - -- TODO(wpcarro): Validate incoming data like startDate. + listAccounts :: T.SessionCookie -> Handler [T.User] + listAccounts cookie = adminsOnly cookie $ do + liftIO $ Accounts.list dbFile + + createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent + createTrip cookie trip@T.Trip{..} = + adminsAnd cookie (\T.Account{..} -> accountUsername == tripUsername) $ do + liftIO $ Trips.create dbFile trip + pure NoContent + deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent - deleteTrip cookie tripPK = do + deleteTrip cookie tripPK@T.TripPK{..} = + adminsAnd cookie (\T.Account{..} -> accountUsername == tripPKUsername) $ do liftIO $ Trips.delete dbFile tripPK pure NoContent diff --git a/src/Auth.hs b/src/Auth.hs index 6a2436058..4962ce50a 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -3,9 +3,13 @@ -------------------------------------------------------------------------------- module Auth where -------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Data.String.Conversions (cs) import Database.SQLite.Simple import Utils import Web.Cookie +import Servant +import Servant.Server.Internal.ServerError import qualified Data.UUID as UUID import qualified Web.Cookie as WC @@ -22,9 +26,9 @@ uuidFromCookie (T.SessionCookie cookies) = do uuid <- UUID.fromASCIIBytes auth pure $ T.SessionUUID uuid --- | Attempt to return the user role associated with the `cookie`. -roleFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Role) -roleFromCookie dbFile cookie = withConnection dbFile $ \conn -> do +-- | Attempt to return the account associated with `cookie`. +accountFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Account) +accountFromCookie dbFile cookie = withConnection dbFile $ \conn -> do case uuidFromCookie cookie of Nothing -> pure Nothing Just uuid -> do @@ -35,7 +39,7 @@ roleFromCookie dbFile cookie = withConnection dbFile $ \conn -> do mAccount <- Accounts.lookup dbFile storedSessionUsername case mAccount of Nothing -> pure Nothing - Just T.Account{..} -> pure (Just accountRole) + Just x -> pure (Just x) -- | Create a new session cookie. mkCookie :: T.SessionUUID -> SetCookie @@ -52,3 +56,15 @@ emptyCookie = { setCookieName = "auth" , setCookieValue = "" } + +-- | Throw a 401 error if the `predicate` fails. +assert :: FilePath -> T.SessionCookie -> (T.Account -> Bool) -> Handler a -> Handler a +assert dbFile cookie predicate handler = do + mRole <- liftIO $ accountFromCookie dbFile cookie + case mRole of + Nothing -> throwError err401 { errBody = "Missing valid session cookie" } + Just account -> + if predicate account then + handler + else + throwError err401 { errBody = "You are not authorized to access this resource" } From b6e8389edd486d407025383825a1beaf6b7f63b7 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 13:58:50 +0100 Subject: [PATCH 37/79] Read env variables using envy library Using my dear friend's, dmjio's, excellent library, envy -- to read and parse variables from the system environment. I added and git-ignored the .envrc file that contains API secrets. I'm using Envy to read these values, so that I don't hard-code these values into the source code. --- .gitignore | 1 + shell.nix | 1 + src/App.hs | 24 ++++++++++++------------ src/Main.hs | 8 +++++++- src/Types.hs | 12 ++++++++++++ 5 files changed, 33 insertions(+), 13 deletions(-) diff --git a/.gitignore b/.gitignore index ebea556fe..d4d62d436 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.envrc *.db *.sqlite3 !populate.sqlite3 diff --git a/shell.nix b/shell.nix index 8c948e9cb..bd31438b1 100644 --- a/shell.nix +++ b/shell.nix @@ -10,6 +10,7 @@ in pkgs.mkShell { hpkgs.warp hpkgs.cryptonite hpkgs.uuid + hpkgs.envy ])) ]; } diff --git a/src/App.hs b/src/App.hs index 708dd896f..7536e3c77 100644 --- a/src/App.hs +++ b/src/App.hs @@ -37,15 +37,15 @@ err429 = ServerError , errHeaders = [] } -server :: FilePath -> Server API -server dbFile = createAccount - :<|> deleteAccount - :<|> listAccounts - :<|> createTrip - :<|> deleteTrip - :<|> listTrips - :<|> login - :<|> logout +server :: T.Config -> Server API +server T.Config{..} = createAccount + :<|> deleteAccount + :<|> listAccounts + :<|> createTrip + :<|> deleteTrip + :<|> listTrips + :<|> login + :<|> logout where -- Admit Admins + whatever the predicate `p` passes. adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) @@ -124,6 +124,6 @@ server dbFile = createAccount liftIO $ Sessions.delete dbFile uuid pure $ addHeader Auth.emptyCookie NoContent -run :: FilePath -> IO () -run dbFile = - Warp.run 3000 (serve (Proxy @ API) $ server dbFile) +run :: T.Config -> IO () +run config = + Warp.run 3000 (serve (Proxy @ API) $ server config) diff --git a/src/Main.hs b/src/Main.hs index de40b3225..9df423206 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,13 @@ +-------------------------------------------------------------------------------- module Main where -------------------------------------------------------------------------------- import qualified App +import qualified System.Envy as Envy -------------------------------------------------------------------------------- main :: IO () -main = App.run "../db.sqlite3" +main = do + mEnv <- Envy.decodeEnv + case mEnv of + Left err -> putStrLn err + Right env -> App.run env diff --git a/src/Types.hs b/src/Types.hs index eed9bf8c1..135c50f17 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -16,6 +16,7 @@ import Database.SQLite.Simple.ToField import GHC.Generics import Web.Cookie import Servant.API +import System.Envy (FromEnv, fromEnv, env) import Crypto.Random.Types (MonadRandom) import qualified Crypto.KDF.BCrypt as BC @@ -26,6 +27,17 @@ import qualified Data.Text.Encoding as TE import qualified Data.UUID as UUID -------------------------------------------------------------------------------- +-- | Top-level application configuration. +data Config = Config + { mailgunAPIKey :: Text + , dbFile :: FilePath + } deriving (Eq, Show) + +instance FromEnv Config where + fromEnv _ = + Config <$> env "MAILGUN_API_KEY" + <*> env "DB_FILE" + -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b forNewtype wrapper field = From 30838b8df7350d9dd37b5873f21247d6bddefc15 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 17:05:05 +0100 Subject: [PATCH 38/79] Add Haskell client library for MailGun Whichever package is on nixpkgs right now is broken, so I'm using `fetchGit` and `callCabal2nix`. Create Email module exposing a simplifies `send` function that partially applies some of the configuration options. --- shell.nix | 6 ++++++ src/Email.hs | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+) create mode 100644 src/Email.hs diff --git a/shell.nix b/shell.nix index bd31438b1..811061186 100644 --- a/shell.nix +++ b/shell.nix @@ -1,5 +1,10 @@ let pkgs = import {}; + hailgun-src = builtins.fetchGit { + url = "https://bitbucket.org/echo_rm/hailgun.git"; + rev = "9d5da7c902b2399e0fcf3d494ee04cf2bbfe7c9e"; + }; + hailgun = pkgs.haskellPackages.callCabal2nix "hailgun" hailgun-src {}; in pkgs.mkShell { buildInputs = with pkgs; [ (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [ @@ -11,6 +16,7 @@ in pkgs.mkShell { hpkgs.cryptonite hpkgs.uuid hpkgs.envy + hailgun ])) ]; } diff --git a/src/Email.hs b/src/Email.hs new file mode 100644 index 000000000..439b15d0e --- /dev/null +++ b/src/Email.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Email where +-------------------------------------------------------------------------------- +import Data.Text +import Data.String.Conversions (cs) +import Utils + +import qualified Mail.Hailgun as MG +import qualified Types as T +-------------------------------------------------------------------------------- + +newtype SendSuccess = SendSuccess MG.HailgunSendResponse + +data SendError + = MessageError MG.HailgunErrorMessage + | ResponseError MG.HailgunErrorResponse + +-- | Attempt to send an email with `subject` and with message, `body`. +send :: Text + -> Text + -> Text + -> T.Email + -> IO (Either SendError SendSuccess) +send apiKey subject body (T.Email to) = do + case mkMsg of + Left e -> pure $ Left (MessageError e) + Right x -> do + res <- MG.sendEmail ctx x + case res of + Left e -> pure $ Left (ResponseError e) + Right x -> pure $ Right (SendSuccess x) + where + ctx = MG.HailgunContext { MG.hailgunDomain = "sandboxda5038873f924b50af2f82a0f05cffdf.mailgun.org" + , MG.hailgunApiKey = cs apiKey + , MG.hailgunProxy = Nothing + } + mkMsg = MG.hailgunMessage + subject + (body |> cs |> MG.TextOnly) + "mailgun@sandboxda5038873f924b50af2f82a0f05cffdf.mailgun.org" + (MG.MessageRecipients { MG.recipientsTo = [cs to] + , MG.recipientsCC = [] + , MG.recipientsBCC = [] + }) + [] From dec8890190ff0b86f1a50044814701ef39b808e6 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 18:38:46 +0100 Subject: [PATCH 39/79] 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 - src/API.hs | 4 ++ src/Accounts.hs | 14 +++++++ src/App.hs | 55 +++++++++++++++++++++++--- src/PendingAccounts.hs | 32 +++++++++++++++ src/Types.hs | 89 +++++++++++++++++++++++++++++++----------- src/init.sql | 14 ++++++- 7 files changed, 178 insertions(+), 31 deletions(-) create mode 100644 src/PendingAccounts.hs diff --git a/data/accounts.csv b/data/accounts.csv index 1f8b01582..f5fc77b6d 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 01f7b7b75..0ae3112ae 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 c18a599a3..97ffaf43d 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 7536e3c77..9a4c3ae20 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 000000000..9f86d1dd0 --- /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 135c50f17..d03aae9c7 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 117a3bd06..b616fdece 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; From 6ecab8c3a625d58fa5c4c5daf62a6567b4fc7701 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 18:52:45 +0100 Subject: [PATCH 40/79] Prefer SELECT (a,b,c) to SELECT * "SELECT *" in SQL may not guarantee the order in which a record's columns are returned. For example, in my FromRow instances for Account, I make successive call The following scenario silently and erroneously assigns: firstName, lastName = lastName, firstName ```sql CREATE TABLE People ( firstName TEXT NOT NULL, lastName TEXT NOT NULL, age INTEGER NOT NULL, PRIMARY KEY (firstName, lastName) ) ``` ```haskell data Person = Person { firstName :: String, lastName :: String, age :: Integer } fromRow = do firstName <- field lastName <- field age <- field pure Person{..} getPeople :: Connection -> IO [Person] getPeople conn = query conn "SELECT * FROM People" ``` This silently fails because both firstName and lastName are Strings, and so the FromRow Person instance type-checks, but you should expect to receive a list of names like "Wallace William" instead of "William Wallace". The following won't break the type-checker, but will result in a runtime parsing error: ```haskell -- all code from the previous example remains the same except for: fromRow = do age <- field firstName <- field lastName <- field ``` The "SELECT *" will return records like (firstName,lastName,age), but the FromRow instance for Person will attempt to parse firstName as Integer. So... what have we learned? Prefer "SELECT (firstName,lastName,age)" instead of "SELECT *". --- src/Accounts.hs | 4 ++-- src/PendingAccounts.hs | 2 +- src/Sessions.hs | 6 +++--- src/Trips.hs | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Accounts.hs b/src/Accounts.hs index 97ffaf43d..e8865baa9 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -37,7 +37,7 @@ delete dbFile username = withConnection dbFile $ \conn -> do -- | Attempt to find `username` in the Account table of `dbFile`. lookup :: FilePath -> T.Username -> IO (Maybe T.Account) lookup dbFile username = withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Accounts WHERE username = ?" (Only username) + res <- query conn "SELECT (username,password,email,role,profilePicture) FROM Accounts WHERE username = ?" (Only username) case res of [x] -> pure (Just x) _ -> pure Nothing @@ -45,5 +45,5 @@ lookup dbFile username = withConnection dbFile $ \conn -> do -- | Return a list of accounts with the sensitive data removed. list :: FilePath -> IO [T.User] list dbFile = withConnection dbFile $ \conn -> do - accounts <- query_ conn "SELECT * FROM Accounts" + accounts <- query_ conn "SELECT (username,password,email,role,profilePicture) FROM Accounts" pure $ T.userFromAccount <$> accounts diff --git a/src/PendingAccounts.hs b/src/PendingAccounts.hs index 9f86d1dd0..412f02ad8 100644 --- a/src/PendingAccounts.hs +++ b/src/PendingAccounts.hs @@ -22,7 +22,7 @@ create dbFile secret username password role email = withConnection dbFile $ \con 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) + res <- query conn "SELECT (secret,username,password,role,email) FROM PendingAccounts WHERE username = ?" (Only username) case res of [x] -> pure (Just x) _ -> pure Nothing diff --git a/src/Sessions.hs b/src/Sessions.hs index 19099fe2e..054495e05 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -20,7 +20,7 @@ isValid session = do -- | Lookup the session by UUID. get :: FilePath -> T.SessionUUID -> IO (Maybe T.StoredSession) get dbFile uuid = withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Sessions WHERE uuid = ?" (Only uuid) + res <- query conn "SELECT (uuid,username,tsCreated) FROM Sessions WHERE uuid = ?" (Only uuid) case res of [x] -> pure (Just x) _ -> pure Nothing @@ -28,7 +28,7 @@ get dbFile uuid = withConnection dbFile $ \conn -> do -- | Lookup the session stored under `username` in `dbFile`. find :: FilePath -> T.Username -> IO (Maybe T.StoredSession) find dbFile username = withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Sessions WHERE username = ?" (Only username) + res <- query conn "SELECT (uuid,username,tsCreated) FROM Sessions WHERE username = ?" (Only username) case res of [x] -> pure (Just x) _ -> pure Nothing @@ -71,4 +71,4 @@ findOrCreate dbFile account = withConnection dbFile $ \conn -> -- | Return a list of all sessions in the Sessions table. list :: FilePath -> IO [T.StoredSession] list dbFile = withConnection dbFile $ \conn -> - query_ conn "SELECT * FROM Sessions" + query_ conn "SELECT (uuid,username,tsCreated) FROM Sessions" diff --git a/src/Trips.hs b/src/Trips.hs index 0d805cbe8..a7880b503 100644 --- a/src/Trips.hs +++ b/src/Trips.hs @@ -24,4 +24,4 @@ delete dbFile tripPK = -- | Return a list of all of the trips in `dbFile`. list :: FilePath -> IO [T.Trip] list dbFile = withConnection dbFile $ \conn -> - query_ conn "SELECT * FROM Trips" + query_ conn "SELECT (username,destination,startDate,endDate,comment) FROM Trips" From 8ebc89b44b3fc0e6025b33a3e7ec37e9ebb385cc Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 19:52:04 +0100 Subject: [PATCH 41/79] Remove erroneous parens around columns in SELECT statement These were causing runtime errors... whoops! --- src/Accounts.hs | 4 ++-- src/LoginAttempts.hs | 2 +- src/PendingAccounts.hs | 2 +- src/Sessions.hs | 6 +++--- src/Trips.hs | 2 +- 5 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Accounts.hs b/src/Accounts.hs index e8865baa9..c7ab7a2f1 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -37,7 +37,7 @@ delete dbFile username = withConnection dbFile $ \conn -> do -- | Attempt to find `username` in the Account table of `dbFile`. lookup :: FilePath -> T.Username -> IO (Maybe T.Account) lookup dbFile username = withConnection dbFile $ \conn -> do - res <- query conn "SELECT (username,password,email,role,profilePicture) FROM Accounts WHERE username = ?" (Only username) + res <- query conn "SELECT username,password,email,role,profilePicture FROM Accounts WHERE username = ?" (Only username) case res of [x] -> pure (Just x) _ -> pure Nothing @@ -45,5 +45,5 @@ lookup dbFile username = withConnection dbFile $ \conn -> do -- | Return a list of accounts with the sensitive data removed. list :: FilePath -> IO [T.User] list dbFile = withConnection dbFile $ \conn -> do - accounts <- query_ conn "SELECT (username,password,email,role,profilePicture) FROM Accounts" + accounts <- query_ conn "SELECT username,password,email,role,profilePicture FROM Accounts" pure $ T.userFromAccount <$> accounts diff --git a/src/LoginAttempts.hs b/src/LoginAttempts.hs index a7e950da7..f5a5bde6a 100644 --- a/src/LoginAttempts.hs +++ b/src/LoginAttempts.hs @@ -17,7 +17,7 @@ reset dbFile username = withConnection dbFile $ \conn -> -- `username`. Returns a Maybe in case `username` doesn't exist. forUsername :: FilePath -> T.Username -> IO (Maybe Integer) forUsername dbFile username = withConnection dbFile $ \conn -> do - res <- query conn "SELECT (numAttempts) FROM LoginAttempts WHERE username = ?" + res <- query conn "SELECT username,numAttempts FROM LoginAttempts WHERE username = ?" (Only username) case res of [T.LoginAttempt{..}] -> pure (Just loginAttemptNumAttempts) diff --git a/src/PendingAccounts.hs b/src/PendingAccounts.hs index 412f02ad8..a555185fa 100644 --- a/src/PendingAccounts.hs +++ b/src/PendingAccounts.hs @@ -22,7 +22,7 @@ create dbFile secret username password role email = withConnection dbFile $ \con get :: FilePath -> T.Username -> IO (Maybe T.PendingAccount) get dbFile username = withConnection dbFile $ \conn -> do - res <- query conn "SELECT (secret,username,password,role,email) FROM PendingAccounts WHERE username = ?" (Only username) + res <- query conn "SELECT secret,username,password,role,email FROM PendingAccounts WHERE username = ?" (Only username) case res of [x] -> pure (Just x) _ -> pure Nothing diff --git a/src/Sessions.hs b/src/Sessions.hs index 054495e05..f5b2f6f41 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -20,7 +20,7 @@ isValid session = do -- | Lookup the session by UUID. get :: FilePath -> T.SessionUUID -> IO (Maybe T.StoredSession) get dbFile uuid = withConnection dbFile $ \conn -> do - res <- query conn "SELECT (uuid,username,tsCreated) FROM Sessions WHERE uuid = ?" (Only uuid) + res <- query conn "SELECT uuid,username,tsCreated FROM Sessions WHERE uuid = ?" (Only uuid) case res of [x] -> pure (Just x) _ -> pure Nothing @@ -28,7 +28,7 @@ get dbFile uuid = withConnection dbFile $ \conn -> do -- | Lookup the session stored under `username` in `dbFile`. find :: FilePath -> T.Username -> IO (Maybe T.StoredSession) find dbFile username = withConnection dbFile $ \conn -> do - res <- query conn "SELECT (uuid,username,tsCreated) FROM Sessions WHERE username = ?" (Only username) + res <- query conn "SELECT uuid,username,tsCreated FROM Sessions WHERE username = ?" (Only username) case res of [x] -> pure (Just x) _ -> pure Nothing @@ -71,4 +71,4 @@ findOrCreate dbFile account = withConnection dbFile $ \conn -> -- | Return a list of all sessions in the Sessions table. list :: FilePath -> IO [T.StoredSession] list dbFile = withConnection dbFile $ \conn -> - query_ conn "SELECT (uuid,username,tsCreated) FROM Sessions" + query_ conn "SELECT uuid,username,tsCreated FROM Sessions" diff --git a/src/Trips.hs b/src/Trips.hs index a7880b503..55bc6b958 100644 --- a/src/Trips.hs +++ b/src/Trips.hs @@ -24,4 +24,4 @@ delete dbFile tripPK = -- | Return a list of all of the trips in `dbFile`. list :: FilePath -> IO [T.Trip] list dbFile = withConnection dbFile $ \conn -> - query_ conn "SELECT (username,destination,startDate,endDate,comment) FROM Trips" + query_ conn "SELECT username,destination,startDate,endDate,comment FROM Trips" From ea31a014977c68c808f914556dfe9a04e96205eb Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 19:52:37 +0100 Subject: [PATCH 42/79] Debug LoginAttempts.increment When this was an UPDATE statement with a WHERE clause, and the LoginAttempts table was vacant, nothing would happen. Thankfully, SQLite supports an UPSERT clause so that I can INSERT a new record or UPDATE conditionally. And the best part is: it works! --- src/LoginAttempts.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/LoginAttempts.hs b/src/LoginAttempts.hs index f5a5bde6a..d78e12e3f 100644 --- a/src/LoginAttempts.hs +++ b/src/LoginAttempts.hs @@ -23,7 +23,8 @@ forUsername dbFile username = withConnection dbFile $ \conn -> do [T.LoginAttempt{..}] -> pure (Just loginAttemptNumAttempts) _ -> pure Nothing +-- | INSERT a failed login attempt for `username` or UPDATE an existing entry. increment :: FilePath -> T.Username -> IO () increment dbFile username = withConnection dbFile $ \conn -> - execute conn "UPDATE LoginAttempts SET numAttempts = numAttempts + 1 WHERE username = ?" - (Only username) + execute conn "INSERT INTO LoginAttempts (username,numAttempts) VALUES (?,?) ON CONFLICT (username) DO UPDATE SET numAttempts = numAttempts + 1" + (username, 1 :: Integer) From 75437b01b660700a4ba8d7c46b49d1031beb951b Mon Sep 17 00:00:00 2001 From: William Carroll Date: Thu, 30 Jul 2020 19:53:46 +0100 Subject: [PATCH 43/79] Check for GTE instead of GT Somebody incremenet the total number of off-by-one errors that I've made in my career. I think the current count is 99... or is it 100? 101? Who knows?! --- src/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/App.hs b/src/App.hs index 9a4c3ae20..273bb3951 100644 --- a/src/App.hs +++ b/src/App.hs @@ -145,7 +145,7 @@ server T.Config{..} = createAccount liftIO $ LoginAttempts.increment dbFile username throwError err401 { errBody = "Your credentials are invalid" } Just attempts -> - if attempts > 3 then + if attempts >= 3 then throwError err429 else if T.passwordsMatch password accountPassword then do uuid <- liftIO $ Sessions.findOrCreate dbFile account From 7d64011cbd6b0d6ce2237de2a3dfcc1f9f81a4c9 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 10:55:10 +0100 Subject: [PATCH 44/79] Protect GET /trips with a session cookie When an admin requests /trips, they see all of the trips in the Trips table. When a user requests /trips, they see only their trips. --- src/API.hs | 1 + src/App.hs | 11 +++++++++-- src/Trips.hs | 10 ++++++++-- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/src/API.hs b/src/API.hs index 0ae3112ae..1bcc47b3a 100644 --- a/src/API.hs +++ b/src/API.hs @@ -48,6 +48,7 @@ type API = :> Delete '[JSON] NoContent -- trips: List :<|> "trips" + :> SessionCookie :> Get '[JSON] [T.Trip] -- Miscellaneous diff --git a/src/App.hs b/src/App.hs index 273bb3951..4f02cb444 100644 --- a/src/App.hs +++ b/src/App.hs @@ -126,8 +126,15 @@ server T.Config{..} = createAccount liftIO $ Trips.delete dbFile tripPK pure NoContent - listTrips :: Handler [T.Trip] - listTrips = liftIO $ Trips.list dbFile + listTrips :: T.SessionCookie -> Handler [T.Trip] + listTrips cookie = do + mAccount <- liftIO $ Auth.accountFromCookie dbFile cookie + case mAccount of + Nothing -> throwError err401 { errBody = "Your session cookie is invalid. Try logging out and logging back in." } + Just T.Account{..} -> + case accountRole of + T.Admin -> liftIO $ Trips.listAll dbFile + _ -> liftIO $ Trips.list dbFile accountUsername login :: T.AccountCredentials -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent) diff --git a/src/Trips.hs b/src/Trips.hs index 55bc6b958..ec52ec58f 100644 --- a/src/Trips.hs +++ b/src/Trips.hs @@ -22,6 +22,12 @@ delete dbFile tripPK = (tripPK |> T.tripPKFields) -- | Return a list of all of the trips in `dbFile`. -list :: FilePath -> IO [T.Trip] -list dbFile = withConnection dbFile $ \conn -> +listAll :: FilePath -> IO [T.Trip] +listAll dbFile = withConnection dbFile $ \conn -> query_ conn "SELECT username,destination,startDate,endDate,comment FROM Trips" + +-- | Return a list of all of the trips in `dbFile`. +list :: FilePath -> T.Username -> IO [T.Trip] +list dbFile username = withConnection dbFile $ \conn -> + query conn "SELECT username,destination,startDate,endDate,comment FROM Trips WHERE username = ?" + (Only username) From ed557fb6be749b0b06666674e35db4a75655af08 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 11:25:36 +0100 Subject: [PATCH 45/79] Support PATCH /trips Support a top-level PATCH request to trips that permits any admin to update any trip, and any user to update any of their trips. I'm using Aeson's (:?) combinator to support missing fields from the incoming JSON requests, and then M.fromMaybe to apply these values to any record that matches the primary key. See the TODOs that I introduced for some shortcomings. --- src/API.hs | 4 ++++ src/App.hs | 14 ++++++++++++++ src/Trips.hs | 15 ++++++++++++--- src/Types.hs | 28 ++++++++++++++++++++++++++++ 4 files changed, 58 insertions(+), 3 deletions(-) diff --git a/src/API.hs b/src/API.hs index 1bcc47b3a..cc737c16b 100644 --- a/src/API.hs +++ b/src/API.hs @@ -41,6 +41,10 @@ type API = :> Post '[JSON] NoContent -- trips: Read -- trips: Update + :<|> "trips" + :> SessionCookie + :> ReqBody '[JSON] T.UpdateTripRequest + :> Patch '[JSON] NoContent -- trips: Delete :<|> "trips" :> SessionCookie diff --git a/src/App.hs b/src/App.hs index 4f02cb444..df7091051 100644 --- a/src/App.hs +++ b/src/App.hs @@ -62,6 +62,7 @@ server T.Config{..} = createAccount :<|> deleteAccount :<|> listAccounts :<|> createTrip + :<|> updateTrip :<|> deleteTrip :<|> listTrips :<|> login @@ -120,6 +121,19 @@ server T.Config{..} = createAccount liftIO $ Trips.create dbFile trip pure NoContent + updateTrip :: T.SessionCookie -> T.UpdateTripRequest -> Handler NoContent + updateTrip cookie updates@T.UpdateTripRequest{..} = + adminsAnd cookie (\T.Account{..} -> accountUsername == T.tripPKUsername updateTripRequestTripPK) $ do + mTrip <- liftIO $ Trips.get dbFile updateTripRequestTripPK + case mTrip of + Nothing -> throwError err400 { errBody = "tripKey is invalid" } + Just trip@T.Trip{..} -> do + -- TODO(wpcarro): Prefer function in Trips module that does this in a + -- DB transaction. + liftIO $ Trips.delete dbFile updateTripRequestTripPK + liftIO $ Trips.create dbFile (T.updateTrip updates trip) + pure NoContent + deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent deleteTrip cookie tripPK@T.TripPK{..} = adminsAnd cookie (\T.Account{..} -> accountUsername == tripPKUsername) $ do diff --git a/src/Trips.hs b/src/Trips.hs index ec52ec58f..022631219 100644 --- a/src/Trips.hs +++ b/src/Trips.hs @@ -14,12 +14,21 @@ create dbFile trip = withConnection dbFile $ \conn -> execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" (trip |> T.tripFields) --- | Delete a trip from `dbFile` using its `tripPK` Primary Key. +-- | Attempt to get the trip record from `dbFile` under `tripKey`. +get :: FilePath -> T.TripPK -> IO (Maybe T.Trip) +get dbFile tripKey = withConnection dbFile $ \conn -> do + res <- query conn "SELECT username,destination,startDate,endDate,comment FROM Trips WHERE username = ? AND destination = ? AND startDate = ? LIMIT 1" + (T.tripPKFields tripKey) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Delete a trip from `dbFile` using its `tripKey` Primary Key. delete :: FilePath -> T.TripPK -> IO () -delete dbFile tripPK = +delete dbFile tripKey = withConnection dbFile $ \conn -> do execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" - (tripPK |> T.tripPKFields) + (T.tripPKFields tripKey) -- | Return a list of all of the trips in `dbFile`. listAll :: FilePath -> IO [T.Trip] diff --git a/src/Types.hs b/src/Types.hs index d03aae9c7..273d4aecc 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -449,3 +449,31 @@ instance FromRow PendingAccount where pendingAccountRole <- field pendingAccountEmail <- field pure PendingAccount {..} + +data UpdateTripRequest = UpdateTripRequest + { updateTripRequestTripPK :: TripPK + , updateTripRequestDestination :: Maybe Destination + , updateTripRequestStartDate :: Maybe Date + , updateTripRequestEndDate :: Maybe Date + , updateTripRequestComment :: Maybe Comment + } deriving (Eq, Show) + +instance FromJSON UpdateTripRequest where + parseJSON = withObject "UpdateTripRequest" $ \x -> do + updateTripRequestTripPK <- x .: "tripKey" + -- the following four fields might not be present + updateTripRequestDestination <- x .:? "destination" + updateTripRequestStartDate <- x .:? "startDate" + updateTripRequestEndDate <- x .:? "endDate" + updateTripRequestComment <- x .:? "comment" + pure UpdateTripRequest{..} + +-- | Apply the updates in the UpdateTripRequest to Trip. +updateTrip :: UpdateTripRequest -> Trip -> Trip +updateTrip UpdateTripRequest{..} Trip{..} = Trip + { tripUsername = tripUsername + , tripDestination = M.fromMaybe tripDestination updateTripRequestDestination + , tripStartDate = M.fromMaybe tripStartDate updateTripRequestStartDate + , tripEndDate = M.fromMaybe tripEndDate updateTripRequestEndDate + , tripComment = M.fromMaybe tripComment updateTripRequestComment + } From 43eff5f1d037b3e45a3b7a274048527e2a95103d Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 11:27:47 +0100 Subject: [PATCH 46/79] Prefer RecordWildCards for FromJSON instances Stylistically, I think this looks cleaner. --- src/Types.hs | 46 ++++++++++++++++++---------------------------- 1 file changed, 18 insertions(+), 28 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 273d4aecc..485111f38 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -250,13 +250,10 @@ tripPKFields (TripPK{ tripPKUsername instance FromJSON TripPK where parseJSON = withObject "TripPK" $ \x -> do - username <- x .: "username" - destination <- x .: "destination" - startDate <- x .: "startDate" - pure TripPK{ tripPKUsername = username - , tripPKDestination = destination - , tripPKStartDate = startDate - } + tripPKUsername <- x .: "username" + tripPKDestination <- x .: "destination" + tripPKStartDate <- x .: "startDate" + pure TripPK{..} -- | Return the tuple representation of a Trip record for SQL. tripFields :: Trip -> (Username, Destination, Date, Date, Comment) @@ -284,17 +281,12 @@ instance ToJSON Trip where instance FromJSON Trip where parseJSON = withObject "Trip" $ \x -> do - username <- x .: "username" - destination <- x .: "destination" - startDate <- x .: "startDate" - endDate <- x .: "endDate" - comment <- x .: "comment" - pure Trip{ tripUsername = username - , tripDestination = destination - , tripStartDate = startDate - , tripEndDate = endDate - , tripComment = comment - } + tripUsername <- x .: "username" + tripDestination <- x .: "destination" + tripStartDate <- x .: "startDate" + tripEndDate <- x .: "endDate" + tripComment <- x .: "comment" + pure Trip{..} -- | Users and Accounts both refer to the same underlying entities; however, -- Users model the user-facing Account details, hiding sensitive details like @@ -328,11 +320,9 @@ data AccountCredentials = AccountCredentials instance FromJSON AccountCredentials where parseJSON = withObject "AccountCredentials" $ \x -> do - username <- x.: "username" - password <- x.: "password" - pure AccountCredentials{ accountCredentialsUsername = username - , accountCredentialsPassword = password - } + accountCredentialsUsername <- x.: "username" + accountCredentialsPassword <- x.: "password" + pure AccountCredentials{..} -- | Hash password `x`. @@ -355,11 +345,11 @@ data CreateAccountRequest = CreateAccountRequest instance FromJSON CreateAccountRequest where parseJSON = withObject "CreateAccountRequest" $ \x -> do - username <- x .: "username" - password <- x .: "password" - email <- x .: "email" - role <- x .: "role" - pure $ CreateAccountRequest username password email role + createAccountRequestUsername <- x .: "username" + createAccountRequestPassword <- x .: "password" + createAccountRequestEmail <- x .: "email" + createAccountRequestRole <- x .: "role" + pure $ CreateAccountRequest{..} createAccountRequestFields :: CreateAccountRequest -> (Username, ClearTextPassword, Email, Role) createAccountRequestFields request = From 1d7c77f51d287c9d636630142791952890d17622 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 11:37:45 +0100 Subject: [PATCH 47/79] Support POST /unfreeze Allow admins and managers to unfreeze accounts that we froze for security reasons. --- src/API.hs | 4 ++++ src/App.hs | 9 +++++++++ src/Types.hs | 9 +++++++++ 3 files changed, 22 insertions(+) diff --git a/src/API.hs b/src/API.hs index cc737c16b..8bdb6bdfb 100644 --- a/src/API.hs +++ b/src/API.hs @@ -62,3 +62,7 @@ type API = :<|> "logout" :> SessionCookie :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) + :<|> "unfreeze" + :> SessionCookie + :> ReqBody '[JSON] T.UnfreezeAccountRequest + :> Post '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index df7091051..e3806610a 100644 --- a/src/App.hs +++ b/src/App.hs @@ -67,6 +67,7 @@ server T.Config{..} = createAccount :<|> listTrips :<|> login :<|> logout + :<|> unfreezeAccount where -- Admit Admins + whatever the predicate `p` passes. adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) @@ -188,6 +189,14 @@ server T.Config{..} = createAccount liftIO $ Sessions.delete dbFile uuid pure $ addHeader Auth.emptyCookie NoContent + unfreezeAccount :: T.SessionCookie + -> T.UnfreezeAccountRequest + -> Handler NoContent + unfreezeAccount cookie T.UnfreezeAccountRequest{..} = + adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) $ do + liftIO $ LoginAttempts.reset dbFile unfreezeAccountRequestUsername + pure NoContent + run :: T.Config -> IO () run config = Warp.run 3000 (serve (Proxy @ API) $ server config) diff --git a/src/Types.hs b/src/Types.hs index 485111f38..7bfdf6cfd 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -467,3 +467,12 @@ updateTrip UpdateTripRequest{..} Trip{..} = Trip , tripEndDate = M.fromMaybe tripEndDate updateTripRequestEndDate , tripComment = M.fromMaybe tripComment updateTripRequestComment } + +data UnfreezeAccountRequest = UnfreezeAccountRequest + { unfreezeAccountRequestUsername :: Username + } deriving (Eq, Show) + +instance FromJSON UnfreezeAccountRequest where + parseJSON = withObject "UnfreezeAccountRequest" $ \x -> do + unfreezeAccountRequestUsername <- x .: "username" + pure UnfreezeAccountRequest{..} From c8ed6e51fea30ea2f79cca058c4f161625ab6a85 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 18:26:47 +0100 Subject: [PATCH 48/79] Read CLIENT and SERVER endpoints from .envrc In the spirit of DRY. --- src/App.hs | 39 ++++++++++++++++++++------------------- src/Types.hs | 4 ++++ 2 files changed, 24 insertions(+), 19 deletions(-) diff --git a/src/App.hs b/src/App.hs index e3806610a..ff292ff2c 100644 --- a/src/App.hs +++ b/src/App.hs @@ -41,12 +41,13 @@ err429 = ServerError } -- | 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 +sendVerifyEmail :: T.Config + -> Text + -> T.Username + -> T.Email + -> T.RegistrationSecret + -> IO (Either Email.SendError Email.SendSuccess) +sendVerifyEmail T.Config{..} 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" @@ -54,20 +55,20 @@ sendVerifyEmail apiKey (T.Username username) email@(T.Email to) (T.RegistrationS -- 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 + cs configServer ++ cs username ++ "&secret=" ++ secret server :: T.Config -> Server API -server T.Config{..} = createAccount - :<|> verifyAccount - :<|> deleteAccount - :<|> listAccounts - :<|> createTrip - :<|> updateTrip - :<|> deleteTrip - :<|> listTrips - :<|> login - :<|> logout - :<|> unfreezeAccount +server config@T.Config{..} = createAccount + :<|> verifyAccount + :<|> deleteAccount + :<|> listAccounts + :<|> createTrip + :<|> updateTrip + :<|> deleteTrip + :<|> listTrips + :<|> login + :<|> logout + :<|> unfreezeAccount where -- Admit Admins + whatever the predicate `p` passes. adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) @@ -84,7 +85,7 @@ server T.Config{..} = createAccount createAccountRequestPassword createAccountRequestRole createAccountRequestEmail - liftIO $ sendVerifyEmail mailgunAPIKey + liftIO $ sendVerifyEmail config mailgunAPIKey createAccountRequestUsername createAccountRequestEmail secretUUID diff --git a/src/Types.hs b/src/Types.hs index 7bfdf6cfd..f47e14197 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -33,12 +33,16 @@ import qualified Data.UUID as UUID data Config = Config { mailgunAPIKey :: Text , dbFile :: FilePath + , configClient :: Text + , configServer :: Text } deriving (Eq, Show) instance FromEnv Config where fromEnv _ = do mailgunAPIKey <- env "MAILGUN_API_KEY" dbFile <- env "DB_FILE" + configClient <- env "CLIENT" + configServer <- env "SERVER" pure Config {..} -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. From 35b218c5436ec5ad8fdae3d45a8a949d06b0d920 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 18:28:41 +0100 Subject: [PATCH 49/79] Return a JSON Session on a successful POST /login This will make the UX on a the client-side smoother. --- src/API.hs | 2 +- src/App.hs | 12 +++++++++--- src/Types.hs | 4 ++-- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/API.hs b/src/API.hs index 8bdb6bdfb..7b6ed9eae 100644 --- a/src/API.hs +++ b/src/API.hs @@ -58,7 +58,7 @@ type API = -- Miscellaneous :<|> "login" :> ReqBody '[JSON] T.AccountCredentials - :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) + :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] T.Session) :<|> "logout" :> SessionCookie :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) diff --git a/src/App.hs b/src/App.hs index ff292ff2c..e5b8de7e7 100644 --- a/src/App.hs +++ b/src/App.hs @@ -153,7 +153,7 @@ server config@T.Config{..} = createAccount _ -> liftIO $ Trips.list dbFile accountUsername login :: T.AccountCredentials - -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent) + -> Handler (Headers '[Header "Set-Cookie" SetCookie] T.Session) login (T.AccountCredentials username password) = do mAccount <- liftIO $ Accounts.lookup dbFile username case mAccount of @@ -163,7 +163,10 @@ server config@T.Config{..} = createAccount Nothing -> if T.passwordsMatch password accountPassword then do uuid <- liftIO $ Sessions.findOrCreate dbFile account - pure $ addHeader (Auth.mkCookie uuid) NoContent + pure $ addHeader (Auth.mkCookie uuid) + T.Session{ sessionUsername = accountUsername + , sessionRole = accountRole + } else do liftIO $ LoginAttempts.increment dbFile username throwError err401 { errBody = "Your credentials are invalid" } @@ -172,7 +175,10 @@ server config@T.Config{..} = createAccount throwError err429 else if T.passwordsMatch password accountPassword then do uuid <- liftIO $ Sessions.findOrCreate dbFile account - pure $ addHeader (Auth.mkCookie uuid) NoContent + pure $ addHeader (Auth.mkCookie uuid) + T.Session{ sessionUsername = accountUsername + , sessionRole = accountRole + } else do liftIO $ LoginAttempts.increment dbFile username throwError err401 { errBody = "Your credentials are invalid" } diff --git a/src/Types.hs b/src/Types.hs index f47e14197..5026b9738 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -174,8 +174,8 @@ instance FromRow Account where pure Account{..} data Session = Session - { username :: Username - , role :: Role + { sessionUsername :: Username + , sessionRole :: Role } deriving (Eq, Show) instance ToJSON Session where From cdaa449670318373fa581263284ed09d75645ac5 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 18:29:22 +0100 Subject: [PATCH 50/79] Prefer PUT to PATCH It was always a PUT. Nothing to see here, folks. --- src/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/API.hs b/src/API.hs index 7b6ed9eae..461c85112 100644 --- a/src/API.hs +++ b/src/API.hs @@ -44,7 +44,7 @@ type API = :<|> "trips" :> SessionCookie :> ReqBody '[JSON] T.UpdateTripRequest - :> Patch '[JSON] NoContent + :> Put '[JSON] NoContent -- trips: Delete :<|> "trips" :> SessionCookie From 29a00dc571b53b08064915c34e0d951467b6f1e4 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 18:30:21 +0100 Subject: [PATCH 51/79] Configure non-simple CORS server-side @dmjio says (probably correctly) that it's best to just serve the client from the server and circumvent CORS issues altogether. One day I will set that up. For now, this works... *sigh* --- shell.nix | 1 + src/App.hs | 16 +++++++++++++--- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/shell.nix b/shell.nix index 811061186..567b71060 100644 --- a/shell.nix +++ b/shell.nix @@ -12,6 +12,7 @@ in pkgs.mkShell { hpkgs.aeson hpkgs.resource-pool hpkgs.sqlite-simple + hpkgs.wai-cors hpkgs.warp hpkgs.cryptonite hpkgs.uuid diff --git a/src/App.hs b/src/App.hs index e5b8de7e7..abd1bfba9 100644 --- a/src/App.hs +++ b/src/App.hs @@ -10,13 +10,14 @@ module App where import Control.Monad.IO.Class (liftIO) import Data.String.Conversions (cs) import Data.Text (Text) -import Network.Wai.Handler.Warp as Warp import Servant import Servant.Server.Internal.ServerError import API import Utils import Web.Cookie +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Cors as Cors import qualified System.Random as Random import qualified Email as Email import qualified Crypto.KDF.BCrypt as BC @@ -205,5 +206,14 @@ server config@T.Config{..} = createAccount pure NoContent run :: T.Config -> IO () -run config = - Warp.run 3000 (serve (Proxy @ API) $ server config) +run config@T.Config{..} = + Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server config) + where + enforceCors = Cors.cors (const $ Just corsPolicy) + corsPolicy :: Cors.CorsResourcePolicy + corsPolicy = + Cors.simpleCorsResourcePolicy + { Cors.corsOrigins = Just ([cs configClient], True) + , Cors.corsMethods = Cors.simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] + , Cors.corsRequestHeaders = Cors.simpleHeaders ++ ["Content-Type", "Authorization"] + } From 421c71c8922731563771ed75be7f28c9a559c068 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 18:32:00 +0100 Subject: [PATCH 52/79] Support a basic client-side login flow I will need to remove some of the baggage like: - Scrub any copy about restaurants - delete Restaurant.elm - Change Owner.elm -> Manager.elm --- client/README.md | 1 + client/dir-locals.nix | 2 +- client/elm.json | 16 +- client/shell.nix | 1 + client/src/Admin.elm | 99 +++++++++ client/src/Landing.elm | 13 -- client/src/Login.elm | 213 +++++++++++++++++- client/src/Main.elm | 63 ++++-- client/src/Manager.elm | 46 ++++ client/src/Shared.elm | 7 + client/src/State.elm | 482 ++++++++++++++++++++++++++++++++++++++-- client/src/Tailwind.elm | 29 +++ client/src/UI.elm | 254 +++++++++++++++++++++ client/src/User.elm | 39 ++++ client/src/Utils.elm | 90 ++++++++ 15 files changed, 1301 insertions(+), 54 deletions(-) create mode 100644 client/src/Admin.elm delete mode 100644 client/src/Landing.elm create mode 100644 client/src/Manager.elm create mode 100644 client/src/Shared.elm create mode 100644 client/src/Tailwind.elm create mode 100644 client/src/UI.elm create mode 100644 client/src/User.elm create mode 100644 client/src/Utils.elm diff --git a/client/README.md b/client/README.md index 425d5163e..04804ad94 100644 --- a/client/README.md +++ b/client/README.md @@ -11,6 +11,7 @@ in which you can develop: ```shell $ nix-shell +$ npx tailwindcss build index.css -o output.css $ elm-live -- src/Main.elm --output=Main.min.js ``` diff --git a/client/dir-locals.nix b/client/dir-locals.nix index 498f4b505..5c3ae0887 100644 --- a/client/dir-locals.nix +++ b/client/dir-locals.nix @@ -1,3 +1,3 @@ let - briefcase = import {}; + briefcase = import /home/wpcarro/briefcase {}; in briefcase.utils.nixBufferFromShell ./shell.nix diff --git a/client/elm.json b/client/elm.json index a95f80408..76664b62b 100644 --- a/client/elm.json +++ b/client/elm.json @@ -9,18 +9,26 @@ "elm/browser": "1.0.2", "elm/core": "1.0.5", "elm/html": "1.0.0", + "elm/http": "2.0.0", + "elm/json": "1.1.3", "elm/random": "1.0.0", "elm/svg": "1.0.1", "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm-community/json-extra": "4.2.0", "elm-community/list-extra": "8.2.3", "elm-community/maybe-extra": "5.2.0", - "elm-community/random-extra": "3.1.0" + "elm-community/random-extra": "3.1.0", + "krisajenkins/remotedata": "6.0.1", + "ryannhg/date-format": "2.3.0" }, "indirect": { - "elm/json": "1.1.3", - "elm/url": "1.0.0", + "elm/bytes": "1.0.8", + "elm/file": "1.0.5", + "elm/parser": "1.1.0", "elm/virtual-dom": "1.0.2", - "owanturist/elm-union-find": "1.0.0" + "owanturist/elm-union-find": "1.0.0", + "rtfeldman/elm-iso8601-date-strings": "1.1.3" } }, "test-dependencies": { diff --git a/client/shell.nix b/client/shell.nix index 6f1c8ee23..15ac040b9 100644 --- a/client/shell.nix +++ b/client/shell.nix @@ -2,6 +2,7 @@ let pkgs = import {}; in pkgs.mkShell { buildInputs = with pkgs; [ + nodejs elmPackages.elm elmPackages.elm-format elmPackages.elm-live diff --git a/client/src/Admin.elm b/client/src/Admin.elm new file mode 100644 index 000000000..3c0f221d9 --- /dev/null +++ b/client/src/Admin.elm @@ -0,0 +1,99 @@ +module Admin exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import RemoteData +import State +import Tailwind +import UI +import Utils + + +allUsers : State.Model -> Html State.Msg +allUsers model = + case model.users of + RemoteData.NotAsked -> + UI.absentData { handleFetch = State.AttemptGetUsers } + + RemoteData.Loading -> + UI.paragraph "Loading..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + div [] + [ UI.header 3 "Admins" + , users xs.admin + , UI.header 3 "Managers" + , users xs.manager + , UI.header 3 "Users" + , users xs.user + ] + + +users : List String -> Html State.Msg +users xs = + ul [] + (xs + |> List.map + (\x -> + li [ [ "py-4", "flex" ] |> Tailwind.use |> class ] + [ p [ [ "flex-1" ] |> Tailwind.use |> class ] [ text x ] + , div [ [ "flex-1" ] |> Tailwind.use |> class ] + [ UI.simpleButton + { label = "Delete" + , handleClick = State.AttemptDeleteUser x + } + ] + ] + ) + ) + + +render : State.Model -> Html State.Msg +render model = + div + [ [ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + |> class + ] + [ UI.header 2 "Welcome back!" + , UI.simpleButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + , div [] + [ UI.baseButton + { label = "Switch to users" + , handleClick = State.UpdateAdminTab State.Users + , enabled = not (model.adminTab == State.Users) + , extraClasses = [] + } + ] + , case model.adminTab of + State.Users -> + allUsers model + , case model.logoutError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error logging out" + , body = Utils.explainHttpError e + } + , case model.deleteUserError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error attempting to delete user" + , body = Utils.explainHttpError e + } + ] diff --git a/client/src/Landing.elm b/client/src/Landing.elm deleted file mode 100644 index 00bb9e281..000000000 --- a/client/src/Landing.elm +++ /dev/null @@ -1,13 +0,0 @@ -module Landing exposing (render) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import State - - -render : State.Model -> Html State.Msg -render model = - div [ class "pt-10 pb-20 px-10" ] - [ p [] [ text "Welcome to the landing page!" ] - ] diff --git a/client/src/Login.elm b/client/src/Login.elm index 968325d48..046ee8583 100644 --- a/client/src/Login.elm +++ b/client/src/Login.elm @@ -4,13 +4,214 @@ import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) import State +import Tailwind +import UI +import Utils + + +loginForm : State.Model -> Html State.Msg +loginForm model = + div + [ [ "w-full" + , "max-w-xs" + , "mx-auto" + ] + |> Tailwind.use + |> class + ] + [ div + [ [ "bg-white" + , "shadow-md" + , "rounded" + , "px-8" + , "pt-6" + , "pb-8" + , "mb-4" + , "text-left" + ] + |> Tailwind.use + |> class + ] + [ div + [ [ "mb-4" ] |> Tailwind.use |> class ] + [ UI.label_ { for_ = "username", text_ = "Username" } + , UI.textField + { inputId = "Username" + , pholder = "Username" + , handleInput = State.UpdateUsername + , inputValue = model.username + } + ] + , div [] + [ UI.label_ { for_ = "role", text_ = "Role" } + , select + [ [ "mb-4" + , "w-full" + , "py-2" + , "px-2" + , "rounded" + , "shadow" + , "border" + ] + |> Tailwind.use + |> class + , id "role" + , onInput State.UpdateRole + ] + [ option [] [ text "" ] + , option [ value "user" ] [ text "User" ] + , option [ value "manager" ] [ text "Manager" ] + , option [ value "admin" ] [ text "Admin" ] + ] + ] + , div + [ [ "mb-4" ] |> Tailwind.use |> class ] + [ UI.label_ { for_ = "password", text_ = "Password" } + , input + [ [ "shadow" + , "appearance-none" + , "border" + , "rounded" + , "w-full" + , "py-2" + , "px-3" + , "text-gray-700" + , "leading-tight" + , "focus:outline-none" + , "focus:shadow-outline" + ] + |> Tailwind.use + |> class + , id "password" + , type_ "password" + , placeholder "******************" + , onInput State.UpdatePassword + ] + [] + ] + , div + [] + [ UI.baseButton + { label = "Sign In" + , handleClick = State.AttemptLogin + , extraClasses = [] + , enabled = + case ( model.username, model.password ) of + ( "", "" ) -> + False + + ( "", _ ) -> + False + + ( _, "" ) -> + False + + _ -> + True + } + , div [ [ "inline", "pl-2" ] |> Tailwind.use |> class ] + [ UI.baseButton + { label = "Sign Up" + , extraClasses = [] + , enabled = + case ( model.username, model.password, model.role ) of + ( "", "", _ ) -> + False + + ( _, "", _ ) -> + False + + ( "", _, _ ) -> + False + + ( _, _, Nothing ) -> + False + + _ -> + True + , handleClick = + case model.role of + Just role -> + State.AttemptSignUp role + + Nothing -> + State.DoNothing + } + ] + ] + ] + ] + + +login : + State.Model + -> Html State.Msg +login model = + div + [ [ "text-center" + , "py-20" + , "bg-gray-200" + , "h-screen" + ] + |> Tailwind.use + |> class + ] + [ UI.header 3 "Welcome to Trip Planner" + , loginForm model + , case model.loginError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error logging in" + , body = Utils.explainHttpError e + } + , case model.signUpError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error creating account" + , body = Utils.explainHttpError e + } + ] + + +logout : State.Model -> Html State.Msg +logout model = + div + [ [ "text-center" + , "py-20" + , "bg-gray-200" + , "h-screen" + ] + |> Tailwind.use + |> class + ] + [ UI.header 3 "Looks like you're already signed in..." + , UI.simpleButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + , case model.logoutError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error logging out" + , body = Utils.explainHttpError e + } + ] -googleSignIn : Html State.Msg -googleSignIn = - div [ class "g-signin2", attribute "onsuccess" "onSignIn" ] [] render : State.Model -> Html State.Msg render model = - div [ class "pt-10 pb-20 px-10" ] - [ googleSignIn - ] + case model.session of + Nothing -> + login model + + Just x -> + logout model diff --git a/client/src/Main.elm b/client/src/Main.elm index 30006460c..de71a72db 100644 --- a/client/src/Main.elm +++ b/client/src/Main.elm @@ -1,31 +1,62 @@ module Main exposing (main) +import Admin import Browser import Html exposing (..) -import Landing import Login +import Manager import State +import Url +import User -subscriptions : State.Model -> Sub State.Msg -subscriptions model = - Sub.none - - -view : State.Model -> Html State.Msg -view model = - case model.view of - State.Landing -> - Landing.render model - +viewForRoute : State.Route -> (State.Model -> Html State.Msg) +viewForRoute route = + case route of State.Login -> - Login.render model + Login.render + + State.UserHome -> + User.render + + State.ManagerHome -> + Manager.render + + State.AdminHome -> + Admin.render + + +view : State.Model -> Browser.Document State.Msg +view model = + { title = "TripPlanner" + , body = + [ case ( model.session, model.route ) of + -- Redirect to /login when someone is not authenticated. + -- TODO(wpcarro): We should ensure that /login shows in the URL + -- bar. + ( Nothing, _ ) -> + Login.render model + + ( Just session, Nothing ) -> + Login.render model + + -- Authenticated + ( Just session, Just route ) -> + if State.isAuthorized session.role route then + viewForRoute route model + + else + text "Access denied. You are not authorized to be here. Evacuate the area immediately" + ] + } main = - Browser.element - { init = \() -> ( State.init, Cmd.none ) - , subscriptions = subscriptions + Browser.application + { init = State.init + , onUrlChange = State.UrlChanged + , onUrlRequest = State.LinkClicked + , subscriptions = \_ -> Sub.none , update = State.update , view = view } diff --git a/client/src/Manager.elm b/client/src/Manager.elm new file mode 100644 index 000000000..b7f36cfd4 --- /dev/null +++ b/client/src/Manager.elm @@ -0,0 +1,46 @@ +module Manager exposing (render) + +import Array +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import RemoteData +import State +import Tailwind +import UI +import Utils + + +render : State.Model -> Html State.Msg +render model = + case model.session of + Nothing -> + text "You are unauthorized to view this page." + + Just session -> + div + [ class + ([ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + ) + ] + [ h1 [] + [ UI.header 2 ("Welcome back, " ++ session.username ++ "!") + , UI.simpleButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + , case model.logoutError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error logging out" + , body = Utils.explainHttpError e + } + ] + ] diff --git a/client/src/Shared.elm b/client/src/Shared.elm new file mode 100644 index 000000000..addb0a4ff --- /dev/null +++ b/client/src/Shared.elm @@ -0,0 +1,7 @@ +module Shared exposing (..) + +clientOrigin = + "http://localhost:8000" + +serverOrigin = + "http://localhost:3000" diff --git a/client/src/State.elm b/client/src/State.elm index 8c56a7ecc..8595ee4dd 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -1,29 +1,322 @@ module State exposing (..) +import Array exposing (Array) +import Browser +import Browser.Navigation as Nav +import Http +import Json.Decode as JD +import Json.Decode.Extra as JDE +import Json.Encode as JE +import Process +import RemoteData exposing (WebData) +import Shared +import Task +import Time +import Url +import Url.Builder as UrlBuilder +import Url.Parser exposing ((), Parser, int, map, oneOf, s, string) +import Utils + + + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + type Msg = DoNothing - | SetView View + | UpdateUsername String + | UpdatePassword String + | UpdateRole String + | UpdateAdminTab AdminTab + | ClearErrors + -- SPA + | LinkClicked Browser.UrlRequest + | UrlChanged Url.Url + -- Outbound network + | AttemptGetUsers + | AttemptSignUp Role + | AttemptLogin + | AttemptLogout + | AttemptDeleteUser String + -- Inbound network + | GotUsers (WebData AllUsers) + | GotSignUp (Result Http.Error Session) + | GotLogin (Result Http.Error Session) + | GotLogout (Result Http.Error String) + | GotDeleteUser (Result Http.Error String) -type View - = Landing - | Login +type Route + = Login + | UserHome + | ManagerHome + | AdminHome + + +type Role + = User + | Manager + | Admin + + +type alias AllUsers = + { user : List String + , manager : List String + , admin : List String + } + + +type alias Session = + { role : Role + , username : String + } + + +type alias Review = + { rowid : Int + , content : String + , rating : Int + , user : String + , dateOfVisit : String + } + + +type alias Reviews = + { hi : Maybe Review + , lo : Maybe Review + , all : List Review + } + + +type AdminTab + = Users type alias Model = - { isLoading : Bool - , view : View + { route : Maybe Route + , url : Url.Url + , key : Nav.Key + , session : Maybe Session + , username : String + , password : String + , role : Maybe Role + , users : WebData AllUsers + , adminTab : AdminTab + , loginError : Maybe Http.Error + , logoutError : Maybe Http.Error + , signUpError : Maybe Http.Error + , deleteUserError : Maybe Http.Error } + +-------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------- + + +roleToString : Role -> String +roleToString role = + case role of + User -> + "user" + + Manager -> + "manager" + + Admin -> + "admin" + + +endpoint : List String -> List UrlBuilder.QueryParameter -> String +endpoint = + UrlBuilder.crossOrigin Shared.serverOrigin + + +decodeRole : JD.Decoder Role +decodeRole = + let + toRole : String -> JD.Decoder Role + toRole s = + case s of + "user" -> + JD.succeed User + + "manager" -> + JD.succeed Manager + + "admin" -> + JD.succeed Admin + + _ -> + JD.succeed User + in + JD.string |> JD.andThen toRole + + +decodeSession : JD.Decoder Session +decodeSession = + JD.map2 + Session + (JD.field "role" decodeRole) + (JD.field "username" JD.string) + + +encodeLoginRequest : String -> String -> JE.Value +encodeLoginRequest username password = + JE.object + [ ( "username", JE.string username ) + , ( "password", JE.string password ) + ] + + +login : String -> String -> Cmd Msg +login username password = + Utils.postWithCredentials + { url = endpoint [ "login" ] [] + , body = Http.jsonBody (encodeLoginRequest username password) + , expect = Http.expectJson GotLogin decodeSession + } + + +logout : Cmd Msg +logout = + Utils.getWithCredentials + { url = endpoint [ "logout" ] [] + , expect = Http.expectString GotLogout + } + + +signUp : + { username : String + , password : String + , role : Role + } + -> Cmd Msg +signUp { username, password, role } = + Utils.postWithCredentials + { url = endpoint [ "create-account" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "username", JE.string username ) + , ( "password", JE.string password ) + , ( "role" + , case role of + User -> + JE.string "user" + + Manager -> + JE.string "manager" + + Admin -> + JE.string "admin" + ) + ] + ) + , expect = Http.expectJson GotSignUp decodeSession + } + + +deleteUser : String -> Cmd Msg +deleteUser username = + Utils.deleteWithCredentials + { url = endpoint [ "user", username ] [] + , expect = Http.expectString GotDeleteUser + } + + +decodeReview : JD.Decoder Review +decodeReview = + JD.map5 + Review + (JD.field "rowid" JD.int) + (JD.field "content" JD.string) + (JD.field "rating" JD.int) + (JD.field "user" JD.string) + (JD.field "timestamp" JD.string) + + +fetchUsers : Cmd Msg +fetchUsers = + Utils.getWithCredentials + { url = endpoint [ "all-usernames" ] [] + , expect = + Http.expectJson + (RemoteData.fromResult >> GotUsers) + (JD.map3 + AllUsers + (JD.field "user" (JD.list JD.string)) + (JD.field "manager" (JD.list JD.string)) + (JD.field "admin" (JD.list JD.string)) + ) + } + + +sleepAndClearErrors : Cmd Msg +sleepAndClearErrors = + Process.sleep 4000 + |> Task.perform (\_ -> ClearErrors) + + +isAuthorized : Role -> Route -> Bool +isAuthorized role route = + case ( role, route ) of + ( User, _ ) -> + True + + ( Manager, _ ) -> + True + + ( Admin, _ ) -> + True + + +homeRouteForRole : Role -> String +homeRouteForRole role = + case role of + User -> + "/user" + + Manager -> + "/manager" + + Admin -> + "/admin" + + +routeParser : Parser (Route -> a) a +routeParser = + oneOf + [ map Login (s "topic") + , map UserHome (s "user") + , map ManagerHome (s "manager") + , map AdminHome (s "admin") + ] + + {-| The initial state for the application. -} -init : Model -init = - { isLoading = False - , view = Login - } +init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +init _ url key = + ( { route = Nothing + , url = url + , key = key + , session = Nothing + , username = "" + , password = "" + , role = Nothing + , users = RemoteData.NotAsked + , adminTab = Users + , loginError = Nothing + , logoutError = Nothing + , signUpError = Nothing + , deleteUserError = Nothing + } + , Cmd.none + ) {-| Now that we have state, we need a function to change the state. @@ -34,10 +327,171 @@ update msg model = DoNothing -> ( model, Cmd.none ) - SetView x -> + UpdateUsername x -> + ( { model | username = x }, Cmd.none ) + + UpdatePassword x -> + ( { model | password = x }, Cmd.none ) + + UpdateAdminTab x -> + ( { model | adminTab = x }, Cmd.none ) + + UpdateRole x -> + let + maybeRole = + case x of + "user" -> + Just User + + "owner" -> + Just Manager + + "admin" -> + Just Admin + + _ -> + Nothing + in + ( { model | role = maybeRole }, Cmd.none ) + + ClearErrors -> ( { model - | view = x - , isLoading = True + | loginError = Nothing + , logoutError = Nothing + , signUpError = Nothing + , deleteUserError = Nothing } , Cmd.none ) + + LinkClicked urlRequest -> + case urlRequest of + Browser.Internal url -> + ( model, Nav.pushUrl model.key (Url.toString url) ) + + Browser.External href -> + ( model, Nav.load href ) + + UrlChanged url -> + let + route = + Url.Parser.parse routeParser url + in + case route of + Just UserHome -> + ( { model + | url = url + , route = route + } + , Cmd.none + ) + + Just ManagerHome -> + case model.session of + Nothing -> + ( { model + | url = url + , route = route + } + , Cmd.none + ) + + Just session -> + ( { model + | url = url + , route = route + } + , Cmd.none + ) + + Just AdminHome -> + ( { model + | url = url + , route = route + , users = RemoteData.Loading + } + , Cmd.none + ) + + _ -> + ( { model + | url = url + , route = route + } + , Cmd.none + ) + + -- GET /all-usernames + AttemptGetUsers -> + ( { model | users = RemoteData.Loading }, fetchUsers ) + + GotUsers xs -> + ( { model | users = xs }, Cmd.none ) + + -- DELETE /user/:username + AttemptDeleteUser username -> + ( model, deleteUser username ) + + GotDeleteUser result -> + case result of + Ok _ -> + ( model, fetchUsers ) + + Err e -> + ( { model | deleteUserError = Just e } + , sleepAndClearErrors + ) + + -- /create-account + AttemptSignUp role -> + ( model + , signUp + { username = model.username + , password = model.password + , role = role + } + ) + + GotSignUp result -> + case result of + Ok session -> + ( { model | session = Just session } + , Nav.pushUrl model.key (homeRouteForRole session.role) + ) + + Err x -> + ( { model | signUpError = Just x } + , sleepAndClearErrors + ) + + -- /login + AttemptLogin -> + ( model, login model.username model.password ) + + GotLogin result -> + case result of + Ok session -> + ( { model | session = Just session } + , Nav.pushUrl model.key (homeRouteForRole session.role) + ) + + Err x -> + ( { model | loginError = Just x } + , sleepAndClearErrors + ) + + -- / logout + AttemptLogout -> + ( model, logout ) + + GotLogout result -> + case result of + Ok _ -> + ( { model | session = Nothing } + , Nav.pushUrl model.key "/login" + ) + + Err e -> + ( { model | logoutError = Just e } + , sleepAndClearErrors + ) diff --git a/client/src/Tailwind.elm b/client/src/Tailwind.elm new file mode 100644 index 000000000..57d419db5 --- /dev/null +++ b/client/src/Tailwind.elm @@ -0,0 +1,29 @@ +module Tailwind exposing (..) + +{-| Functions to make Tailwind development in Elm even more pleasant. +-} + + +{-| Conditionally use `class` selection when `condition` is true. +-} +when : Bool -> String -> String +when condition class = + if condition then + class + + else + "" + + +if_ : Bool -> String -> String -> String +if_ condition whenTrue whenFalse = + if condition then + whenTrue + + else + whenFalse + + +use : List String -> String +use styles = + String.join " " styles diff --git a/client/src/UI.elm b/client/src/UI.elm new file mode 100644 index 000000000..565771e21 --- /dev/null +++ b/client/src/UI.elm @@ -0,0 +1,254 @@ +module UI exposing (..) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import State +import Tailwind + + +label_ : { for_ : String, text_ : String } -> Html msg +label_ { for_, text_ } = + label + [ [ "block" + , "text-gray-700" + , "text-sm" + , "font-bold" + , "mb-2" + ] + |> Tailwind.use + |> class + , for for_ + ] + [ text text_ ] + + +errorBanner : { title : String, body : String } -> Html msg +errorBanner { title, body } = + div + [ [ "text-left" + , "fixed" + , "container" + , "top-0" + , "mt-6" + ] + |> Tailwind.use + |> class + , style "left" "50%" + + -- TODO(wpcarro): Consider supporting breakpoints, but for now + -- don't. + , style "margin-left" "-512px" + ] + [ div + [ [ "bg-red-500" + , "text-white" + , "font-bold" + , "rounded-t" + , "px-4" + , "py-2" + ] + |> Tailwind.use + |> class + ] + [ text title ] + , div + [ [ "border" + , "border-t-0" + , "border-red-400" + , "rounded-b" + , "bg-red-100" + , "px-4" + , "py-3" + , "text-red-700" + ] + |> Tailwind.use + |> class + ] + [ p [] [ text body ] ] + ] + + +baseButton : + { label : String + , enabled : Bool + , handleClick : msg + , extraClasses : List String + } + -> Html msg +baseButton { label, enabled, handleClick, extraClasses } = + button + [ [ if enabled then + "bg-blue-500" + + else + "bg-gray-500" + , if enabled then + "hover:bg-blue-700" + + else + "" + , if enabled then + "" + + else + "cursor-not-allowed" + , "text-white" + , "font-bold" + , "py-2" + , "px-4" + , "rounded" + , "focus:outline-none" + , "focus:shadow-outline" + ] + ++ extraClasses + |> Tailwind.use + |> class + , onClick handleClick + , disabled (not enabled) + ] + [ text label ] + + +simpleButton : + { label : String + , handleClick : msg + } + -> Html msg +simpleButton { label, handleClick } = + baseButton + { label = label + , enabled = True + , handleClick = handleClick + , extraClasses = [] + } + + +textField : + { pholder : String + , inputId : String + , handleInput : String -> msg + , inputValue : String + } + -> Html msg +textField { pholder, inputId, handleInput, inputValue } = + input + [ [ "shadow" + , "appearance-none" + , "border" + , "rounded" + , "w-full" + , "py-2" + , "px-3" + , "text-gray-700" + , "leading-tight" + , "focus:outline-none" + , "focus:shadow-outline" + ] + |> Tailwind.use + |> class + , id inputId + , value inputValue + , placeholder pholder + , onInput handleInput + ] + [] + + +toggleButton : + { toggled : Bool + , label : String + , handleEnable : msg + , handleDisable : msg + } + -> Html msg +toggleButton { toggled, label, handleEnable, handleDisable } = + button + [ [ if toggled then + "bg-blue-700" + + else + "bg-blue-500" + , "hover:bg-blue-700" + , "text-white" + , "font-bold" + , "py-2" + , "px-4" + , "rounded" + , "focus:outline-none" + , "focus:shadow-outline" + ] + |> Tailwind.use + |> class + , onClick + (if toggled then + handleDisable + + else + handleEnable + ) + ] + [ text label ] + + +paragraph : String -> Html msg +paragraph x = + p [ [ "text-xl" ] |> Tailwind.use |> class ] [ text x ] + + +header : Int -> String -> Html msg +header which x = + let + hStyles = + case which of + 1 -> + [ "text-6xl" + , "py-12" + ] + + 2 -> + [ "text-3xl" + , "py-6" + ] + + _ -> + [ "text-2xl" + , "py-2" + ] + in + h1 + [ hStyles + ++ [ "font-bold" + , "text-gray-700" + ] + |> Tailwind.use + |> class + ] + [ text x ] + + +link : String -> String -> Html msg +link path label = + a + [ href path + , [ "underline" + , "text-blue-600" + , "text-xl" + ] + |> Tailwind.use + |> class + ] + [ text label ] + + +absentData : { handleFetch : msg } -> Html msg +absentData { handleFetch } = + div [] + [ paragraph "Welp... it looks like you've caught us in a state that we considered impossible: we did not fetch the data upon which this page depends. Maybe you can help us out by clicking the super secret, highly privileged \"Fetch data\" button below (we don't normally show people this)." + , div [ [ "py-4" ] |> Tailwind.use |> class ] + [ simpleButton + { label = "Fetch data" + , handleClick = handleFetch + } + ] + ] diff --git a/client/src/User.elm b/client/src/User.elm new file mode 100644 index 000000000..7139d2028 --- /dev/null +++ b/client/src/User.elm @@ -0,0 +1,39 @@ +module User exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Maybe.Extra +import RemoteData +import State +import Tailwind +import UI +import Utils + + +render : State.Model -> Html State.Msg +render model = + div + [ class + ([ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + ) + ] + [ UI.header 2 ("Welcome, " ++ model.username ++ "!") + , UI.simpleButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + , case model.logoutError of + Nothing -> + text "" + + Just e -> + UI.errorBanner + { title = "Error logging out" + , body = Utils.explainHttpError e + } + ] diff --git a/client/src/Utils.elm b/client/src/Utils.elm new file mode 100644 index 000000000..0f6c61ed2 --- /dev/null +++ b/client/src/Utils.elm @@ -0,0 +1,90 @@ +module Utils exposing (..) + +import DateFormat +import Http +import Time +import Shared + + +explainHttpError : Http.Error -> String +explainHttpError e = + case e of + Http.BadUrl _ -> + "Bad URL: you may have supplied an improperly formatted URL" + + Http.Timeout -> + "Timeout: the resource you requested did not arrive within the interval of time that you claimed it should" + + Http.BadStatus s -> + "Bad Status: the server returned a bad status code: " ++ String.fromInt s + + Http.BadBody b -> + "Bad Body: our application had trouble decoding the body of the response from the server: " ++ b + + Http.NetworkError -> + "Network Error: something went awry in the network stack. I recommend checking the server logs if you can." + + +getWithCredentials : + { url : String + , expect : Http.Expect msg + } + -> Cmd msg +getWithCredentials { url, expect } = + Http.riskyRequest + { url = url + , headers = [ Http.header "Origin" Shared.clientOrigin ] + , method = "GET" + , timeout = Nothing + , tracker = Nothing + , body = Http.emptyBody + , expect = expect + } + + +postWithCredentials : + { url : String + , body : Http.Body + , expect : Http.Expect msg + } + -> Cmd msg +postWithCredentials { url, body, expect } = + Http.riskyRequest + { url = url + , headers = [ Http.header "Origin" Shared.clientOrigin ] + , method = "POST" + , timeout = Nothing + , tracker = Nothing + , body = body + , expect = expect + } + + +deleteWithCredentials : + { url : String + , expect : Http.Expect msg + } + -> Cmd msg +deleteWithCredentials { url, expect } = + Http.riskyRequest + { url = url + , headers = [ Http.header "Origin" Shared.clientOrigin ] + , method = "DELETE" + , timeout = Nothing + , tracker = Nothing + , body = Http.emptyBody + , expect = expect + } + + +formatTime : Time.Posix -> String +formatTime ts = + DateFormat.format + [ DateFormat.monthNameFull + , DateFormat.text " " + , DateFormat.dayOfMonthSuffix + , DateFormat.text ", " + , DateFormat.yearNumber + ] + Time.utc + ts From 4d30a80487fae26e9b0395270dec1a1792a67b6a Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 19:32:14 +0100 Subject: [PATCH 53/79] Support UI.textButton Create a text-only button. --- client/src/UI.elm | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/client/src/UI.elm b/client/src/UI.elm index 565771e21..28b73a8ae 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -124,6 +124,26 @@ simpleButton { label, handleClick } = } +textButton : + { label : String + , handleClick : msg + } + -> Html msg +textButton { label, handleClick } = + button + [ [ "text-blue-600" + , "hover:text-blue-500" + , "font-bold" + , "hover:underline" + , "focus:outline-none" + ] + |> Tailwind.use + |> class + , onClick handleClick + ] + [ text label ] + + textField : { pholder : String , inputId : String From cf5d211477daefd105f9cd8f59195cb4d538086e Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 19:32:30 +0100 Subject: [PATCH 54/79] Support UI.disabledButton While this isn't necessary, it tidies up the code a bit. --- client/src/UI.elm | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/client/src/UI.elm b/client/src/UI.elm index 28b73a8ae..482c6ebe9 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -124,6 +124,18 @@ simpleButton { label, handleClick } = } +disabledButton : + { label : String } + -> Html State.Msg +disabledButton { label } = + baseButton + { label = label + , enabled = False + , handleClick = State.DoNothing + , extraClasses = [] + } + + textButton : { label : String , handleClick : msg From 9666d5dce152f996c7dd2167e0b1a9c2f9f767b0 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Fri, 31 Jul 2020 19:33:18 +0100 Subject: [PATCH 55/79] Support sign-up Toggle b/w logging in or signing up. TL;DR: - From my previous submission's feedback, disallow users from signing themselves up as admins, managers; I just removed the UI element altogether, even though the server still support this (TODO) --- client/src/Login.elm | 121 ++++++++++++++++++------------------------- client/src/State.elm | 54 ++++++++++++------- 2 files changed, 86 insertions(+), 89 deletions(-) diff --git a/client/src/Login.elm b/client/src/Login.elm index 046ee8583..60a45e7fc 100644 --- a/client/src/Login.elm +++ b/client/src/Login.elm @@ -32,7 +32,19 @@ loginForm model = |> Tailwind.use |> class ] - [ div + [ div [ [ "text-center", "pb-6" ] |> Tailwind.use |> class ] + [ UI.textButton + { handleClick = State.ToggleLoginForm + , label = + case model.loginTab of + State.LoginForm -> + "Switch to sign up" + + State.SignUpForm -> + "Switch to login" + } + ] + , div [ [ "mb-4" ] |> Tailwind.use |> class ] [ UI.label_ { for_ = "username", text_ = "Username" } , UI.textField @@ -42,28 +54,35 @@ loginForm model = , inputValue = model.username } ] - , div [] - [ UI.label_ { for_ = "role", text_ = "Role" } - , select - [ [ "mb-4" - , "w-full" - , "py-2" - , "px-2" - , "rounded" - , "shadow" - , "border" - ] - |> Tailwind.use - |> class - , id "role" - , onInput State.UpdateRole - ] - [ option [] [ text "" ] - , option [ value "user" ] [ text "User" ] - , option [ value "manager" ] [ text "Manager" ] - , option [ value "admin" ] [ text "Admin" ] - ] - ] + , case model.loginTab of + State.LoginForm -> + text "" + + State.SignUpForm -> + div + [ [ "mb-4" ] |> Tailwind.use |> class ] + [ UI.label_ { for_ = "email", text_ = "Email" } + , input + [ [ "shadow" + , "appearance-none" + , "border" + , "rounded" + , "w-full" + , "py-2" + , "px-3" + , "text-gray-700" + , "leading-tight" + , "focus:outline-none" + , "focus:shadow-outline" + ] + |> Tailwind.use + |> class + , id "email" + , placeholder "who@domain.tld" + , onInput State.UpdateEmail + ] + [] + ] , div [ [ "mb-4" ] |> Tailwind.use |> class ] [ UI.label_ { for_ = "password", text_ = "Password" } @@ -89,56 +108,16 @@ loginForm model = ] [] ] - , div - [] - [ UI.baseButton - { label = "Sign In" - , handleClick = State.AttemptLogin - , extraClasses = [] - , enabled = - case ( model.username, model.password ) of - ( "", "" ) -> - False + , case model.loginTab of + State.LoginForm -> + UI.simpleButton { handleClick = State.AttemptLogin, label = "Login" } - ( "", _ ) -> - False + State.SignUpForm -> + if String.length model.username > 0 && String.length model.email > 0 && String.length model.password > 0 then + UI.simpleButton { handleClick = State.AttemptSignUp, label = "Sign up" } - ( _, "" ) -> - False - - _ -> - True - } - , div [ [ "inline", "pl-2" ] |> Tailwind.use |> class ] - [ UI.baseButton - { label = "Sign Up" - , extraClasses = [] - , enabled = - case ( model.username, model.password, model.role ) of - ( "", "", _ ) -> - False - - ( _, "", _ ) -> - False - - ( "", _, _ ) -> - False - - ( _, _, Nothing ) -> - False - - _ -> - True - , handleClick = - case model.role of - Just role -> - State.AttemptSignUp role - - Nothing -> - State.DoNothing - } - ] - ] + else + UI.disabledButton { label = "Sign up" } ] ] diff --git a/client/src/State.elm b/client/src/State.elm index 8595ee4dd..e23580a05 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -27,16 +27,18 @@ import Utils type Msg = DoNothing | UpdateUsername String + | UpdateEmail String | UpdatePassword String | UpdateRole String | UpdateAdminTab AdminTab | ClearErrors + | ToggleLoginForm -- SPA | LinkClicked Browser.UrlRequest | UrlChanged Url.Url -- Outbound network | AttemptGetUsers - | AttemptSignUp Role + | AttemptSignUp | AttemptLogin | AttemptLogout | AttemptDeleteUser String @@ -94,16 +96,23 @@ type AdminTab = Users +type LoginTab + = LoginForm + | SignUpForm + + type alias Model = { route : Maybe Route , url : Url.Url , key : Nav.Key , session : Maybe Session , username : String + , email : String , password : String , role : Maybe Role , users : WebData AllUsers , adminTab : AdminTab + , loginTab : LoginTab , loginError : Maybe Http.Error , logoutError : Maybe Http.Error , signUpError : Maybe Http.Error @@ -191,29 +200,20 @@ logout = signUp : { username : String + , email : String , password : String - , role : Role } -> Cmd Msg -signUp { username, password, role } = +signUp { username, email, password } = Utils.postWithCredentials - { url = endpoint [ "create-account" ] [] + { url = endpoint [ "accounts" ] [] , body = Http.jsonBody (JE.object [ ( "username", JE.string username ) + , ( "email", JE.string username ) , ( "password", JE.string password ) - , ( "role" - , case role of - User -> - JE.string "user" - - Manager -> - JE.string "manager" - - Admin -> - JE.string "admin" - ) + , ( "role", JE.string "user" ) ] ) , expect = Http.expectJson GotSignUp decodeSession @@ -306,10 +306,12 @@ init _ url key = , key = key , session = Nothing , username = "" + , email = "" , password = "" , role = Nothing , users = RemoteData.NotAsked , adminTab = Users + , loginTab = LoginForm , loginError = Nothing , logoutError = Nothing , signUpError = Nothing @@ -333,6 +335,9 @@ update msg model = UpdatePassword x -> ( { model | password = x }, Cmd.none ) + UpdateEmail x -> + ( { model | email = x }, Cmd.none ) + UpdateAdminTab x -> ( { model | adminTab = x }, Cmd.none ) @@ -343,7 +348,7 @@ update msg model = "user" -> Just User - "owner" -> + "manager" -> Just Manager "admin" -> @@ -364,6 +369,19 @@ update msg model = , Cmd.none ) + ToggleLoginForm -> + ( { model + | loginTab = + case model.loginTab of + LoginForm -> + SignUpForm + + SignUpForm -> + LoginForm + } + , Cmd.none + ) + LinkClicked urlRequest -> case urlRequest of Browser.Internal url -> @@ -443,12 +461,12 @@ update msg model = ) -- /create-account - AttemptSignUp role -> + AttemptSignUp -> ( model , signUp { username = model.username + , email = model.email , password = model.password - , role = role } ) From a3732300e1c4dfa14a7ba9d7367ebbef914d8398 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sat, 1 Aug 2020 11:46:41 +0100 Subject: [PATCH 56/79] Add exhaustive patterns to FromJSON Role instance When someone enters something like role=mgr, return a helpful error message to the user. Note: I should enable the exhaustive patterns check for GHC. --- src/Types.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Types.hs b/src/Types.hs index 5026b9738..48c26caef 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -114,6 +114,7 @@ instance FromJSON Role where "user" -> pure RegularUser "manager" -> pure Manager "admin" -> pure Admin + _ -> fail "Expected \"user\" or \"manager\" or \"admin\"" instance ToField Role where toField RegularUser = SQLText "user" From 83f4f8e9d669d91602520e1c12d2e8892120e4ba Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sat, 1 Aug 2020 11:48:55 +0100 Subject: [PATCH 57/79] Prevent non-admins from creating Manager or Admin accounts Client-side, I'm not exposing the role option to users. Server-side, I'm asserting that requests to create Manager and Admin accounts are attempted by users with a session tied to an admin account. --- src/API.hs | 1 + src/App.hs | 42 ++++++++++++++++++++++++++++-------------- 2 files changed, 29 insertions(+), 14 deletions(-) diff --git a/src/API.hs b/src/API.hs index 461c85112..956e745b3 100644 --- a/src/API.hs +++ b/src/API.hs @@ -16,6 +16,7 @@ type SessionCookie = Header' '[Required] "Cookie" T.SessionCookie type API = -- accounts: Create "accounts" + :> Header "Cookie" T.SessionCookie :> ReqBody '[JSON] T.CreateAccountRequest :> Post '[JSON] NoContent :<|> "verify" diff --git a/src/App.hs b/src/App.hs index abd1bfba9..6f52dabcc 100644 --- a/src/App.hs +++ b/src/App.hs @@ -77,20 +77,34 @@ server config@T.Config{..} = createAccount adminsOnly cookie = adminsAnd cookie (const True) -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s - createAccount :: T.CreateAccountRequest -> Handler NoContent - createAccount T.CreateAccountRequest{..} = do - secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO - liftIO $ PendingAccounts.create dbFile - secretUUID - createAccountRequestUsername - createAccountRequestPassword - createAccountRequestRole - createAccountRequestEmail - liftIO $ sendVerifyEmail config mailgunAPIKey - createAccountRequestUsername - createAccountRequestEmail - secretUUID - pure NoContent + createAccount :: Maybe T.SessionCookie + -> T.CreateAccountRequest + -> Handler NoContent + createAccount mCookie T.CreateAccountRequest{..} = + case (mCookie, createAccountRequestRole) of + (_, T.RegularUser) -> + doCreateAccount + (Nothing, T.Manager) -> + throwError err401 { errBody = "Only admins can create Manager accounts" } + (Nothing, T.Admin) -> + throwError err401 { errBody = "Only admins can create Admin accounts" } + (Just cookie, _) -> + adminsOnly cookie doCreateAccount + where + doCreateAccount :: Handler NoContent + doCreateAccount = do + secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO + liftIO $ PendingAccounts.create dbFile + secretUUID + createAccountRequestUsername + createAccountRequestPassword + createAccountRequestRole + createAccountRequestEmail + liftIO $ sendVerifyEmail config mailgunAPIKey + createAccountRequestUsername + createAccountRequestEmail + secretUUID + pure NoContent verifyAccount :: Text -> Text -> Handler NoContent verifyAccount username secret = do From 54eb29eae0398dd19f5fdaed278f29453b0b7e44 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sat, 1 Aug 2020 12:29:31 +0100 Subject: [PATCH 58/79] Prefer RecordWildCard syntax for toFields functions Refactoring old code to conform to the latest fashion. --- src/Types.hs | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 48c26caef..7afb29276 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -152,12 +152,7 @@ data Account = Account -- | Return a tuple with all of the fields for an Account record to use for SQL. accountFields :: Account -> (Username, HashedPassword, Email, Role, Maybe ProfilePicture) -accountFields (Account { accountUsername - , accountPassword - , accountEmail - , accountRole - , accountProfilePicture - }) +accountFields (Account {..}) = ( accountUsername , accountPassword , accountEmail @@ -247,10 +242,7 @@ data TripPK = TripPK } deriving (Eq, Show, Generic) tripPKFields :: TripPK -> (Username, Destination, Date) -tripPKFields (TripPK{ tripPKUsername - , tripPKDestination - , tripPKStartDate - }) +tripPKFields (TripPK{..}) = (tripPKUsername, tripPKDestination, tripPKStartDate) instance FromJSON TripPK where @@ -262,12 +254,7 @@ instance FromJSON TripPK where -- | Return the tuple representation of a Trip record for SQL. tripFields :: Trip -> (Username, Destination, Date, Date, Comment) -tripFields (Trip{ tripUsername - , tripDestination - , tripStartDate - , tripEndDate - , tripComment - }) +tripFields (Trip{..}) = ( tripUsername , tripDestination , tripStartDate @@ -356,12 +343,13 @@ instance FromJSON CreateAccountRequest where createAccountRequestRole <- x .: "role" pure $ CreateAccountRequest{..} -createAccountRequestFields :: CreateAccountRequest -> (Username, ClearTextPassword, Email, Role) -createAccountRequestFields request = - ( createAccountRequestUsername request - , createAccountRequestPassword request - , createAccountRequestEmail request - , createAccountRequestRole request +createAccountRequestFields :: CreateAccountRequest + -> (Username, ClearTextPassword, Email, Role) +createAccountRequestFields CreateAccountRequest{..} = + ( createAccountRequestUsername + , createAccountRequestPassword + , createAccountRequestEmail + , createAccountRequestRole ) newtype SessionUUID = SessionUUID UUID.UUID From 249e3113ffbcda047bd9461f01aaa64aa2dd94f1 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sat, 1 Aug 2020 23:04:06 +0100 Subject: [PATCH 59/79] Support creating Trips from the frontend *sigh* ... spent way too much time encoding/decoding date types... I need my database, server, client, and JSON need to agree on types. TL;DR: - Add CSS for elm/datepicker library - Create Common.allErrors to display UI errors - Prefer Data.Time.Calendar.Day instead of newtype Date wrapper around Text --- client/elm.json | 2 + client/index.css | 139 +++++++++++++++++++++++ client/src/Admin.elm | 20 +--- client/src/Common.elm | 27 +++++ client/src/Login.elm | 30 +---- client/src/Manager.elm | 11 +- client/src/State.elm | 242 ++++++++++++++++++++++++++++++++++++----- client/src/UI.elm | 25 +++++ client/src/User.elm | 113 +++++++++++++++++-- src/Types.hs | 40 +++---- 10 files changed, 534 insertions(+), 115 deletions(-) create mode 100644 client/src/Common.elm diff --git a/client/elm.json b/client/elm.json index 76664b62b..c4095e118 100644 --- a/client/elm.json +++ b/client/elm.json @@ -6,6 +6,7 @@ "elm-version": "0.19.1", "dependencies": { "direct": { + "CurrySoftware/elm-datepicker": "4.0.0", "elm/browser": "1.0.2", "elm/core": "1.0.5", "elm/html": "1.0.0", @@ -19,6 +20,7 @@ "elm-community/list-extra": "8.2.3", "elm-community/maybe-extra": "5.2.0", "elm-community/random-extra": "3.1.0", + "justinmimbs/date": "3.2.1", "krisajenkins/remotedata": "6.0.1", "ryannhg/date-format": "2.3.0" }, diff --git a/client/index.css b/client/index.css index b5c61c956..52114e0e9 100644 --- a/client/index.css +++ b/client/index.css @@ -1,3 +1,142 @@ @tailwind base; @tailwind components; @tailwind utilities; + +.elm-datepicker--container { + position: relative; +} + +.elm-datepicker--input:focus { + outline: 0; +} + +.elm-datepicker--picker { + position: absolute; + border: 1px solid #CCC; + z-index: 10; + background-color: white; +} + +.elm-datepicker--picker-header, +.elm-datepicker--weekdays { + background: #F2F2F2; +} + +.elm-datepicker--picker-header { + display: flex; + align-items: center; +} + +.elm-datepicker--prev-container, +.elm-datepicker--next-container { + flex: 0 1 auto; + cursor: pointer; +} + +.elm-datepicker--month-container { + flex: 1 1 auto; + padding: 0.5em; + display: flex; + flex-direction: column; +} + +.elm-datepicker--month, +.elm-datepicker--year { + flex: 1 1 auto; + cursor: default; + text-align: center; +} + +.elm-datepicker--year { + font-size: 0.6em; + font-weight: 700; +} + +.elm-datepicker--prev, +.elm-datepicker--next { + border: 6px solid transparent; + background-color: inherit; + display: block; + width: 0; + height: 0; + padding: 0 0.2em; +} + +.elm-datepicker--prev { + border-right-color: #AAA; +} + +.elm-datepicker--prev:hover { + border-right-color: #BBB; +} + +.elm-datepicker--next { + border-left-color: #AAA; +} + +.elm-datepicker--next:hover { + border-left-color: #BBB; +} + +.elm-datepicker--table { + border-spacing: 0; + border-collapse: collapse; + font-size: 0.8em; +} + +.elm-datepicker--table td { + width: 2em; + height: 2em; + text-align: center; +} + +.elm-datepicker--row { + border-top: 1px solid #F2F2F2; +} + +.elm-datepicker--dow { + border-bottom: 1px solid #CCC; + cursor: default; +} + +.elm-datepicker--day { + cursor: pointer; +} + +.elm-datepicker--day:hover { + background: #F2F2F2; +} + +.elm-datepicker--disabled { + cursor: default; + color: #DDD; +} + +.elm-datepicker--disabled:hover { + background: inherit; +} + +.elm-datepicker--picked { + color: white; + background: darkblue; +} + +.elm-datepicker--picked:hover { + background: darkblue; +} + +.elm-datepicker--today { + font-weight: bold; +} + +.elm-datepicker--other-month { + color: #AAA; +} + +.elm-datepicker--other-month.elm-datepicker--disabled { + color: #EEE; +} + +.elm-datepicker--other-month.elm-datepicker--picked { + color: white; +} diff --git a/client/src/Admin.elm b/client/src/Admin.elm index 3c0f221d9..e8e33bde6 100644 --- a/client/src/Admin.elm +++ b/client/src/Admin.elm @@ -5,6 +5,7 @@ import Html.Attributes exposing (..) import Html.Events exposing (..) import RemoteData import State +import Common import Tailwind import UI import Utils @@ -78,22 +79,5 @@ render model = , case model.adminTab of State.Users -> allUsers model - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } - , case model.deleteUserError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error attempting to delete user" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] diff --git a/client/src/Common.elm b/client/src/Common.elm new file mode 100644 index 000000000..a3106114d --- /dev/null +++ b/client/src/Common.elm @@ -0,0 +1,27 @@ +module Common exposing (..) + +import Html exposing (..) +import Maybe.Extra as ME +import State +import UI +import Utils + + +allErrors : State.Model -> Html State.Msg +allErrors model = + div [] + (State.allErrors + model + |> List.map + (\( mError, title ) -> + case mError of + Nothing -> + text "" + + Just err -> + UI.errorBanner + { title = title + , body = Utils.explainHttpError err + } + ) + ) diff --git a/client/src/Login.elm b/client/src/Login.elm index 60a45e7fc..083c47056 100644 --- a/client/src/Login.elm +++ b/client/src/Login.elm @@ -1,5 +1,6 @@ module Login exposing (render) +import Common import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -137,24 +138,7 @@ login model = ] [ UI.header 3 "Welcome to Trip Planner" , loginForm model - , case model.loginError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging in" - , body = Utils.explainHttpError e - } - , case model.signUpError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error creating account" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] @@ -174,15 +158,7 @@ logout model = { label = "Logout" , handleClick = State.AttemptLogout } - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] diff --git a/client/src/Manager.elm b/client/src/Manager.elm index b7f36cfd4..7cf5dc310 100644 --- a/client/src/Manager.elm +++ b/client/src/Manager.elm @@ -1,6 +1,7 @@ module Manager exposing (render) import Array +import Common import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -33,14 +34,6 @@ render model = { label = "Logout" , handleClick = State.AttemptLogout } - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] ] diff --git a/client/src/State.elm b/client/src/State.elm index e23580a05..66b3e57f0 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -3,6 +3,8 @@ module State exposing (..) import Array exposing (Array) import Browser import Browser.Navigation as Nav +import Date +import DatePicker import Http import Json.Decode as JD import Json.Decode.Extra as JDE @@ -31,6 +33,10 @@ type Msg | UpdatePassword String | UpdateRole String | UpdateAdminTab AdminTab + | UpdateTripDestination String + | UpdateTripStartDate DatePicker.Msg + | UpdateTripEndDate DatePicker.Msg + | UpdateTripComment String | ClearErrors | ToggleLoginForm -- SPA @@ -42,12 +48,15 @@ type Msg | AttemptLogin | AttemptLogout | AttemptDeleteUser String + | AttemptCreateTrip Date.Date Date.Date -- Inbound network | GotUsers (WebData AllUsers) + | GotTrips (WebData (List Trip)) | GotSignUp (Result Http.Error Session) | GotLogin (Result Http.Error Session) | GotLogout (Result Http.Error String) | GotDeleteUser (Result Http.Error String) + | CreatedTrip (Result Http.Error ()) type Route @@ -85,13 +94,6 @@ type alias Review = } -type alias Reviews = - { hi : Maybe Review - , lo : Maybe Review - , all : List Review - } - - type AdminTab = Users @@ -101,6 +103,14 @@ type LoginTab | SignUpForm +type alias Trip = + { destination : String + , startDate : Date.Date + , endDate : Date.Date + , comment : String + } + + type alias Model = { route : Maybe Route , url : Url.Url @@ -111,15 +121,33 @@ type alias Model = , password : String , role : Maybe Role , users : WebData AllUsers + , startDatePicker : DatePicker.DatePicker + , endDatePicker : DatePicker.DatePicker + , tripDestination : String + , tripStartDate : Maybe Date.Date + , tripEndDate : Maybe Date.Date + , tripComment : String + , trips : WebData (List Trip) , adminTab : AdminTab , loginTab : LoginTab , loginError : Maybe Http.Error , logoutError : Maybe Http.Error , signUpError : Maybe Http.Error , deleteUserError : Maybe Http.Error + , createTripError : Maybe Http.Error } +allErrors : Model -> List ( Maybe Http.Error, String ) +allErrors model = + [ ( model.loginError, "Error attempting to authenticate" ) + , ( model.logoutError, "Error attempting to log out" ) + , ( model.signUpError, "Error attempting to create your account" ) + , ( model.deleteUserError, "Error attempting to delete a user" ) + , ( model.createTripError, "Error attempting to create a trip" ) + ] + + -------------------------------------------------------------------------------- -- Functions @@ -220,6 +248,31 @@ signUp { username, email, password } = } +createTrip : + { username : String + , destination : String + , startDate : Date.Date + , endDate : Date.Date + , comment : String + } + -> Cmd Msg +createTrip { username, destination, startDate, endDate, comment } = + Utils.postWithCredentials + { url = endpoint [ "trips" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "username", JE.string username ) + , ( "destination", JE.string destination ) + , ( "startDate", encodeDate startDate ) + , ( "endDate", encodeDate endDate ) + , ( "comment", JE.string comment ) + ] + ) + , expect = Http.expectWhatever CreatedTrip + } + + deleteUser : String -> Cmd Msg deleteUser username = Utils.deleteWithCredentials @@ -239,6 +292,35 @@ decodeReview = (JD.field "timestamp" JD.string) +encodeDate : Date.Date -> JE.Value +encodeDate date = + date |> Date.toIsoString |> JE.string + + +decodeDate : JD.Decoder Date.Date +decodeDate = + JD.string |> JD.andThen (Date.fromIsoString >> JDE.fromResult) + + +fetchTrips : Cmd Msg +fetchTrips = + Utils.getWithCredentials + { url = endpoint [ "trips" ] [] + , expect = + Http.expectJson + (RemoteData.fromResult >> GotTrips) + (JD.list + (JD.map4 + Trip + (JD.field "destination" JD.string) + (JD.field "startDate" decodeDate) + (JD.field "endDate" decodeDate) + (JD.field "comment" JD.string) + ) + ) + } + + fetchUsers : Cmd Msg fetchUsers = Utils.getWithCredentials @@ -301,6 +383,13 @@ routeParser = -} init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) init _ url key = + let + ( startDatePicker, startDatePickerCmd ) = + DatePicker.init + + ( endDatePicker, endDatePickerCmd ) = + DatePicker.init + in ( { route = Nothing , url = url , key = key @@ -310,14 +399,25 @@ init _ url key = , password = "" , role = Nothing , users = RemoteData.NotAsked + , tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + , trips = RemoteData.NotAsked + , startDatePicker = startDatePicker + , endDatePicker = endDatePicker , adminTab = Users , loginTab = LoginForm , loginError = Nothing , logoutError = Nothing , signUpError = Nothing , deleteUserError = Nothing + , createTripError = Nothing } - , Cmd.none + , Cmd.batch + [ Cmd.map UpdateTripStartDate startDatePickerCmd + , Cmd.map UpdateTripEndDate endDatePickerCmd + ] ) @@ -359,12 +459,59 @@ update msg model = in ( { model | role = maybeRole }, Cmd.none ) + UpdateTripDestination x -> + ( { model | tripDestination = x }, Cmd.none ) + + UpdateTripStartDate dpMsg -> + let + ( newDatePicker, dateEvent ) = + DatePicker.update DatePicker.defaultSettings dpMsg model.startDatePicker + + newDate = + case dateEvent of + DatePicker.Picked changedDate -> + Just changedDate + + _ -> + model.tripStartDate + in + ( { model + | tripStartDate = newDate + , startDatePicker = newDatePicker + } + , Cmd.none + ) + + UpdateTripEndDate dpMsg -> + let + ( newDatePicker, dateEvent ) = + DatePicker.update DatePicker.defaultSettings dpMsg model.endDatePicker + + newDate = + case dateEvent of + DatePicker.Picked changedDate -> + Just changedDate + + _ -> + model.tripEndDate + in + ( { model + | tripEndDate = newDate + , endDatePicker = newDatePicker + } + , Cmd.none + ) + + UpdateTripComment x -> + ( { model | tripComment = x }, Cmd.none ) + ClearErrors -> ( { model | loginError = Nothing , logoutError = Nothing , signUpError = Nothing , deleteUserError = Nothing + , createTripError = Nothing } , Cmd.none ) @@ -400,27 +547,18 @@ update msg model = ( { model | url = url , route = route + , trips = RemoteData.Loading } - , Cmd.none + , fetchTrips ) Just ManagerHome -> - case model.session of - Nothing -> - ( { model - | url = url - , route = route - } - , Cmd.none - ) - - Just session -> - ( { model - | url = url - , route = route - } - , Cmd.none - ) + ( { model + | url = url + , route = route + } + , Cmd.none + ) Just AdminHome -> ( { model @@ -439,14 +577,14 @@ update msg model = , Cmd.none ) - -- GET /all-usernames + -- GET /accounts AttemptGetUsers -> ( { model | users = RemoteData.Loading }, fetchUsers ) GotUsers xs -> ( { model | users = xs }, Cmd.none ) - -- DELETE /user/:username + -- DELETE /accounts AttemptDeleteUser username -> ( model, deleteUser username ) @@ -460,7 +598,47 @@ update msg model = , sleepAndClearErrors ) - -- /create-account + -- POST /trips + AttemptCreateTrip startDate endDate -> + ( model + , case model.session of + Nothing -> + Cmd.none + + Just session -> + createTrip + { username = session.username + , destination = model.tripDestination + , startDate = startDate + , endDate = endDate + , comment = model.tripComment + } + ) + + CreatedTrip result -> + case result of + Ok _ -> + ( { model + | tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + } + , fetchTrips + ) + + Err e -> + ( { model + | createTripError = Just e + , tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + } + , sleepAndClearErrors + ) + + -- POST /accounts AttemptSignUp -> ( model , signUp @@ -482,7 +660,11 @@ update msg model = , sleepAndClearErrors ) - -- /login + -- GET /trips + GotTrips xs -> + ( { model | trips = xs }, Cmd.none ) + + -- POST /login AttemptLogin -> ( model, login model.username model.password ) @@ -498,7 +680,7 @@ update msg model = , sleepAndClearErrors ) - -- / logout + -- GET /logout AttemptLogout -> ( model, logout ) diff --git a/client/src/UI.elm b/client/src/UI.elm index 482c6ebe9..1de137fca 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -1,5 +1,7 @@ module UI exposing (..) +import Date +import DatePicker exposing (defaultSettings) import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -284,3 +286,26 @@ absentData { handleFetch } = } ] ] + + +datePicker : + { mDate : Maybe Date.Date + , prompt : String + , prefix : String + , picker : DatePicker.DatePicker + , onUpdate : DatePicker.Msg -> State.Msg + } + -> Html State.Msg +datePicker { mDate, prompt, prefix, picker, onUpdate } = + let + settings = + { defaultSettings + | placeholder = prompt + , inputClassList = + [ ( "text-center", True ) + , ( "py-2", True ) + ] + } + in + div [ [ "w-1/2", "py-4", "mx-auto" ] |> Tailwind.use |> class ] + [ DatePicker.view mDate settings picker |> Html.map onUpdate ] diff --git a/client/src/User.elm b/client/src/User.elm index 7139d2028..5216eeada 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -1,9 +1,12 @@ module User exposing (render) +import Common +import Date +import DatePicker import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import Maybe.Extra +import Maybe.Extra as ME import RemoteData import State import Tailwind @@ -11,6 +14,100 @@ import UI import Utils +createTrip : State.Model -> Html State.Msg +createTrip model = + div [] + [ UI.header 3 "Plan Upcoming Trip" + , UI.textField + { pholder = "Where are you going?" + , inputId = "destination" + , handleInput = State.UpdateTripDestination + , inputValue = model.tripDestination + } + , div [ [ "flex" ] |> Tailwind.use |> class ] + [ UI.datePicker + { mDate = model.tripStartDate + , prompt = "Set departure date" + , prefix = "Departure: " + , picker = model.startDatePicker + , onUpdate = State.UpdateTripStartDate + } + , UI.datePicker + { mDate = model.tripEndDate + , prompt = "Set return date" + , prefix = "Return: " + , picker = model.endDatePicker + , onUpdate = State.UpdateTripEndDate + } + ] + , UI.textField + { pholder = "Comments?" + , inputId = "comment" + , handleInput = State.UpdateTripComment + , inputValue = model.tripComment + } + , UI.baseButton + { enabled = + List.all + identity + [ String.length model.tripDestination > 0 + , String.length model.tripComment > 0 + , ME.isJust model.tripStartDate + , ME.isJust model.tripEndDate + ] + , extraClasses = [ "my-4" ] + , handleClick = + case ( model.tripStartDate, model.tripEndDate ) of + ( Nothing, _ ) -> + State.DoNothing + + ( _, Nothing ) -> + State.DoNothing + + ( Just startDate, Just endDate ) -> + State.AttemptCreateTrip startDate endDate + , label = "Schedule trip" + } + ] + + +trips : State.Model -> Html msg +trips model = + div [] + [ UI.header 3 "Upcoming Trips" + , case model.trips of + RemoteData.NotAsked -> + UI.paragraph "Somehow we've reached the user home page without requesting your trips data. Please report this to our engineering team at bugs@tripplaner.tld" + + RemoteData.Loading -> + UI.paragraph "Loading your trips..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + ul [] + (xs + |> List.map + (\trip -> + li + [ [ "py-2" ] + |> Tailwind.use + |> class + ] + [ text + (Date.toIsoString trip.startDate + ++ " - " + ++ Date.toIsoString trip.endDate + ++ " -> " + ++ trip.destination + ) + ] + ) + ) + ] + + render : State.Model -> Html State.Msg render model = div @@ -23,17 +120,11 @@ render model = ) ] [ UI.header 2 ("Welcome, " ++ model.username ++ "!") - , UI.simpleButton + , createTrip model + , trips model + , UI.textButton { label = "Logout" , handleClick = State.AttemptLogout } - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] diff --git a/src/Types.hs b/src/Types.hs index 7afb29276..11422f8db 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,6 +10,7 @@ import Data.Aeson import Utils import Data.Text import Data.Typeable +import Data.String.Conversions (cs) import Database.SQLite.Simple import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField @@ -20,6 +21,8 @@ import Servant.API import System.Envy (FromEnv, fromEnv, env) import Crypto.Random.Types (MonadRandom) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Format as TF import qualified Crypto.KDF.BCrypt as BC import qualified Data.Time.Clock as Clock import qualified Data.ByteString.Char8 as B @@ -192,19 +195,6 @@ instance ToField Comment where instance FromField Comment where fromField = forNewtype Comment --- TODO(wpcarro): Replace this with a different type. -newtype Date = Date Text - deriving (Eq, Show, Generic) - -instance ToJSON Date -instance FromJSON Date - -instance ToField Date where - toField (Date x) = SQLText x - -instance FromField Date where - fromField = forNewtype Date - newtype Destination = Destination Text deriving (Eq, Show, Generic) @@ -217,11 +207,20 @@ instance ToField Destination where instance FromField Destination where fromField = forNewtype Destination +newtype Year = Year Integer deriving (Eq, Show) +newtype Month = Month Integer deriving (Eq, Show) +newtype Day = Day Integer deriving (Eq, Show) +data Date = Date + { dateYear :: Year + , dateMonth :: Month + , dateDay :: Day + } deriving (Eq, Show) + data Trip = Trip { tripUsername :: Username , tripDestination :: Destination - , tripStartDate :: Date - , tripEndDate :: Date + , tripStartDate :: Calendar.Day + , tripEndDate :: Calendar.Day , tripComment :: Comment } deriving (Eq, Show, Generic) @@ -238,10 +237,10 @@ instance FromRow Trip where data TripPK = TripPK { tripPKUsername :: Username , tripPKDestination :: Destination - , tripPKStartDate :: Date + , tripPKStartDate :: Clock.UTCTime } deriving (Eq, Show, Generic) -tripPKFields :: TripPK -> (Username, Destination, Date) +tripPKFields :: TripPK -> (Username, Destination, Clock.UTCTime) tripPKFields (TripPK{..}) = (tripPKUsername, tripPKDestination, tripPKStartDate) @@ -253,7 +252,8 @@ instance FromJSON TripPK where pure TripPK{..} -- | Return the tuple representation of a Trip record for SQL. -tripFields :: Trip -> (Username, Destination, Date, Date, Comment) +tripFields :: Trip + -> (Username, Destination, Calendar.Day, Calendar.Day, Comment) tripFields (Trip{..}) = ( tripUsername , tripDestination @@ -436,8 +436,8 @@ instance FromRow PendingAccount where data UpdateTripRequest = UpdateTripRequest { updateTripRequestTripPK :: TripPK , updateTripRequestDestination :: Maybe Destination - , updateTripRequestStartDate :: Maybe Date - , updateTripRequestEndDate :: Maybe Date + , updateTripRequestStartDate :: Maybe Calendar.Day + , updateTripRequestEndDate :: Maybe Calendar.Day , updateTripRequestComment :: Maybe Comment } deriving (Eq, Show) From ac9629cad027b2797c016a2a5367d4ad4c04962c Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 10:33:42 +0100 Subject: [PATCH 60/79] Assign fixed width to error banners This makes the banners easier to center horizontally. --- client/src/UI.elm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/client/src/UI.elm b/client/src/UI.elm index 1de137fca..f96dcd8b5 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -40,7 +40,8 @@ errorBanner { title, body } = -- TODO(wpcarro): Consider supporting breakpoints, but for now -- don't. - , style "margin-left" "-512px" + , style "width" "800px" + , style "margin-left" "-400px" ] [ div [ [ "bg-red-500" From 57b6472e2fbd963cc18237d596eb61bb767a1206 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 10:51:26 +0100 Subject: [PATCH 61/79] Define defaults for init in State.elm Problem: When I'm working on a feature, I save my code, and elm-live reloads the browser. This is usually good, except that the application state is reinitialized, which usually means that the view changes. I defined two state configurations, and I expect to define more: - prod: The initial state for the application - userHome: The state I'd like to use when developing a feature for the UserHome page. Idea: For more ad-hoc configurations, I can store the application state in LocalStorage and restore it in between page refreshes. --- client/src/State.elm | 42 +++++++++++++++++++++++++++++++++++++++--- 1 file changed, 39 insertions(+), 3 deletions(-) diff --git a/client/src/State.elm b/client/src/State.elm index 66b3e57f0..190cab7ea 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -379,10 +379,10 @@ routeParser = ] -{-| The initial state for the application. +{-| Set init to `prod` when going live. -} -init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) -init _ url key = +prod : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +prod _ url key = let ( startDatePicker, startDatePickerCmd ) = DatePicker.init @@ -421,6 +421,42 @@ init _ url key = ) +{-| When working on a feature for the UserHome, use this. +-} +userHome : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +userHome flags url key = + let + ( model, cmd ) = + prod flags url key + in + ( { model + | route = Just UserHome + , session = Just { username = "mimi", role = User } + , trips = + RemoteData.Success + [ { destination = "Barcelona" + , startDate = Date.fromCalendarDate 2020 Time.Sep 25 + , endDate = Date.fromCalendarDate 2020 Time.Oct 5 + , comment = "Blah" + } + , { destination = "Paris" + , startDate = Date.fromCalendarDate 2021 Time.Jan 1 + , endDate = Date.fromCalendarDate 2021 Time.Feb 1 + , comment = "Bon voyage!" + } + ] + } + , cmd + ) + + +{-| The initial state for the application. +-} +init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +init flags url key = + prod flags url key + + {-| Now that we have state, we need a function to change the state. -} update : Msg -> Model -> ( Model, Cmd Msg ) From d5bc6f963d4c8cdb8990a9946d9a142a32e13d3c Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 11:13:54 +0100 Subject: [PATCH 62/79] Protect views from a State with an empty Session This should simplify UserHome among other views. --- client/src/Common.elm | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/client/src/Common.elm b/client/src/Common.elm index a3106114d..63ba97b79 100644 --- a/client/src/Common.elm +++ b/client/src/Common.elm @@ -25,3 +25,13 @@ allErrors model = } ) ) + + +withSession : State.Model -> (State.Session -> Html State.Msg) -> Html State.Msg +withSession model renderWithSession = + case model.session of + Nothing -> + div [] [ UI.paragraph "You need a valid session to view this page. Please attempt to log in." ] + + Just session -> + renderWithSession session From 699892883ceaffb64e0d9b9aaab67313a60a5428 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 11:16:24 +0100 Subject: [PATCH 63/79] Support deleting trips from the client TL;DR: - Ensure Types.TripPK in Types.hs uses Calendar.Day for startDate - Prefer verbiage "GotCreateTrip" to "CreatedTrip" - Extend Utils.deleteWithCredentials to accept a body parameter - Support a delete button in the UI --- client/src/State.elm | 57 ++++++++++++++++++++++++++++-- client/src/User.elm | 84 ++++++++++++++++++++++++-------------------- client/src/Utils.elm | 5 +-- src/Types.hs | 4 +-- 4 files changed, 105 insertions(+), 45 deletions(-) diff --git a/client/src/State.elm b/client/src/State.elm index 190cab7ea..d3db7ddf2 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -49,6 +49,7 @@ type Msg | AttemptLogout | AttemptDeleteUser String | AttemptCreateTrip Date.Date Date.Date + | AttemptDeleteTrip String Date.Date -- Inbound network | GotUsers (WebData AllUsers) | GotTrips (WebData (List Trip)) @@ -56,7 +57,8 @@ type Msg | GotLogin (Result Http.Error Session) | GotLogout (Result Http.Error String) | GotDeleteUser (Result Http.Error String) - | CreatedTrip (Result Http.Error ()) + | GotCreateTrip (Result Http.Error ()) + | GotDeleteTrip (Result Http.Error ()) type Route @@ -135,6 +137,7 @@ type alias Model = , signUpError : Maybe Http.Error , deleteUserError : Maybe Http.Error , createTripError : Maybe Http.Error + , deleteTripError : Maybe Http.Error } @@ -269,7 +272,28 @@ createTrip { username, destination, startDate, endDate, comment } = , ( "comment", JE.string comment ) ] ) - , expect = Http.expectWhatever CreatedTrip + , expect = Http.expectWhatever GotCreateTrip + } + + +deleteTrip : + { username : String + , destination : String + , startDate : Date.Date + } + -> Cmd Msg +deleteTrip { username, destination, startDate } = + Utils.deleteWithCredentials + { url = endpoint [ "trips" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "username", JE.string username ) + , ( "destination", JE.string destination ) + , ( "startDate", encodeDate startDate ) + ] + ) + , expect = Http.expectWhatever GotDeleteTrip } @@ -277,6 +301,7 @@ deleteUser : String -> Cmd Msg deleteUser username = Utils.deleteWithCredentials { url = endpoint [ "user", username ] [] + , body = Http.emptyBody , expect = Http.expectString GotDeleteUser } @@ -413,6 +438,7 @@ prod _ url key = , signUpError = Nothing , deleteUserError = Nothing , createTripError = Nothing + , deleteTripError = Nothing } , Cmd.batch [ Cmd.map UpdateTripStartDate startDatePickerCmd @@ -651,7 +677,7 @@ update msg model = } ) - CreatedTrip result -> + GotCreateTrip result -> case result of Ok _ -> ( { model @@ -674,6 +700,31 @@ update msg model = , sleepAndClearErrors ) + -- DELETE /trips + AttemptDeleteTrip destination startDate -> + ( model + , case model.session of + Nothing -> + Cmd.none + + Just session -> + deleteTrip + { username = session.username + , destination = destination + , startDate = startDate + } + ) + + GotDeleteTrip result -> + case result of + Ok _ -> + ( model, fetchTrips ) + + Err e -> + ( { model | deleteTripError = Just e } + , sleepAndClearErrors + ) + -- POST /accounts AttemptSignUp -> ( model diff --git a/client/src/User.elm b/client/src/User.elm index 5216eeada..48aca8652 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -71,7 +71,30 @@ createTrip model = ] -trips : State.Model -> Html msg +renderTrip : State.Trip -> Html State.Msg +renderTrip trip = + li + [ [ "py-2" ] + |> Tailwind.use + |> class + ] + [ p [] + [ text + (Date.toIsoString trip.startDate + ++ " - " + ++ Date.toIsoString trip.endDate + ++ " -> " + ++ trip.destination + ) + ] + , UI.textButton + { label = "Delete" + , handleClick = State.AttemptDeleteTrip trip.destination trip.startDate + } + ] + + +trips : State.Model -> Html State.Msg trips model = div [] [ UI.header 3 "Upcoming Trips" @@ -86,45 +109,30 @@ trips model = UI.paragraph ("Error: " ++ Utils.explainHttpError e) RemoteData.Success xs -> - ul [] - (xs - |> List.map - (\trip -> - li - [ [ "py-2" ] - |> Tailwind.use - |> class - ] - [ text - (Date.toIsoString trip.startDate - ++ " - " - ++ Date.toIsoString trip.endDate - ++ " -> " - ++ trip.destination - ) - ] - ) - ) + ul [] (xs |> List.map renderTrip) ] render : State.Model -> Html State.Msg render model = - div - [ class - ([ "container" - , "mx-auto" - , "text-center" - ] - |> Tailwind.use - ) - ] - [ UI.header 2 ("Welcome, " ++ model.username ++ "!") - , createTrip model - , trips model - , UI.textButton - { label = "Logout" - , handleClick = State.AttemptLogout - } - , Common.allErrors model - ] + Common.withSession model + (\session -> + div + [ class + ([ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + ) + ] + [ UI.header 2 ("Welcome, " ++ session.username ++ "!") + , createTrip model + , trips model + , UI.textButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + , Common.allErrors model + ] + ) diff --git a/client/src/Utils.elm b/client/src/Utils.elm index 0f6c61ed2..28f15fb5c 100644 --- a/client/src/Utils.elm +++ b/client/src/Utils.elm @@ -62,17 +62,18 @@ postWithCredentials { url, body, expect } = deleteWithCredentials : { url : String + , body : Http.Body , expect : Http.Expect msg } -> Cmd msg -deleteWithCredentials { url, expect } = +deleteWithCredentials { url, body, expect } = Http.riskyRequest { url = url , headers = [ Http.header "Origin" Shared.clientOrigin ] , method = "DELETE" , timeout = Nothing , tracker = Nothing - , body = Http.emptyBody + , body = body , expect = expect } diff --git a/src/Types.hs b/src/Types.hs index 11422f8db..54f3ec64e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -237,10 +237,10 @@ instance FromRow Trip where data TripPK = TripPK { tripPKUsername :: Username , tripPKDestination :: Destination - , tripPKStartDate :: Clock.UTCTime + , tripPKStartDate :: Calendar.Day } deriving (Eq, Show, Generic) -tripPKFields :: TripPK -> (Username, Destination, Clock.UTCTime) +tripPKFields :: TripPK -> (Username, Destination, Calendar.Day) tripPKFields (TripPK{..}) = (tripPKUsername, tripPKDestination, tripPKStartDate) From 803db7a5b2f1b8fadda45efce56d6c31a74a1e08 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 14:23:38 +0100 Subject: [PATCH 64/79] Support printing user's itinerary - Define print.css with media=print type (note: could've been handled with @media queries) - Define printPage port to interop with window.print() JS function - Support UI.wrapNoPrint to wrap components with a the no-print CSS --- client/index.html | 9 ++++++-- client/print.css | 3 +++ client/src/State.elm | 11 ++++++++-- client/src/UI.elm | 5 +++++ client/src/User.elm | 51 +++++++++++++++++++++++++++----------------- 5 files changed, 55 insertions(+), 24 deletions(-) create mode 100644 client/print.css diff --git a/client/index.html b/client/index.html index facf4e986..df63ffa06 100644 --- a/client/index.html +++ b/client/index.html @@ -4,7 +4,8 @@ Elm SPA - + + @@ -27,7 +28,11 @@ }); } - Elm.Main.init({node: document.getElementById("mount")}); + var app = Elm.Main.init({node: document.getElementById("mount")}); + + app.ports.printPage.subscribe(function() { + window.print(); + }); diff --git a/client/print.css b/client/print.css new file mode 100644 index 000000000..3cfb27923 --- /dev/null +++ b/client/print.css @@ -0,0 +1,3 @@ +.no-print { + display: none; +} diff --git a/client/src/State.elm b/client/src/State.elm index d3db7ddf2..a8970df24 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -1,4 +1,4 @@ -module State exposing (..) +port module State exposing (..) import Array exposing (Array) import Browser @@ -39,6 +39,7 @@ type Msg | UpdateTripComment String | ClearErrors | ToggleLoginForm + | PrintPage -- SPA | LinkClicked Browser.UrlRequest | UrlChanged Url.Url @@ -476,11 +477,14 @@ userHome flags url key = ) +port printPage : () -> Cmd msg + + {-| The initial state for the application. -} init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) init flags url key = - prod flags url key + userHome flags url key {-| Now that we have state, we need a function to change the state. @@ -591,6 +595,9 @@ update msg model = , Cmd.none ) + PrintPage -> + ( model, printPage () ) + LinkClicked urlRequest -> case urlRequest of Browser.Internal url -> diff --git a/client/src/UI.elm b/client/src/UI.elm index f96dcd8b5..f959b0cc7 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -310,3 +310,8 @@ datePicker { mDate, prompt, prefix, picker, onUpdate } = in div [ [ "w-1/2", "py-4", "mx-auto" ] |> Tailwind.use |> class ] [ DatePicker.view mDate settings picker |> Html.map onUpdate ] + + +wrapNoPrint : Html State.Msg -> Html State.Msg +wrapNoPrint component = + div [ [ "no-print" ] |> Tailwind.use |> class ] [ component ] diff --git a/client/src/User.elm b/client/src/User.elm index 48aca8652..660c3aa7d 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -78,19 +78,20 @@ renderTrip trip = |> Tailwind.use |> class ] - [ p [] - [ text - (Date.toIsoString trip.startDate - ++ " - " - ++ Date.toIsoString trip.endDate - ++ " -> " - ++ trip.destination - ) - ] - , UI.textButton - { label = "Delete" - , handleClick = State.AttemptDeleteTrip trip.destination trip.startDate - } + [ UI.paragraph + (Date.toIsoString trip.startDate + ++ " - " + ++ Date.toIsoString trip.endDate + ++ " -> " + ++ trip.destination + ) + , UI.paragraph ("\"" ++ trip.comment ++ "\"") + , UI.wrapNoPrint + (UI.textButton + { label = "Delete" + , handleClick = State.AttemptDeleteTrip trip.destination trip.startDate + } + ) ] @@ -109,7 +110,15 @@ trips model = UI.paragraph ("Error: " ++ Utils.explainHttpError e) RemoteData.Success xs -> - ul [] (xs |> List.map renderTrip) + div [ [ "mb-10" ] |> Tailwind.use |> class ] + [ ul [ [ "my-4" ] |> Tailwind.use |> class ] (xs |> List.map renderTrip) + , UI.wrapNoPrint + (UI.simpleButton + { label = "Print iternary" + , handleClick = State.PrintPage + } + ) + ] ] @@ -126,13 +135,15 @@ render model = |> Tailwind.use ) ] - [ UI.header 2 ("Welcome, " ++ session.username ++ "!") - , createTrip model + [ UI.wrapNoPrint (UI.header 2 ("Welcome, " ++ session.username ++ "!")) + , UI.wrapNoPrint (createTrip model) , trips model - , UI.textButton - { label = "Logout" - , handleClick = State.AttemptLogout - } + , UI.wrapNoPrint + (UI.textButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + ) , Common.allErrors model ] ) From 81c3db20d4775a115f148ed64c5bc1e54c5a3b65 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 14:31:00 +0100 Subject: [PATCH 65/79] Allow managers to CRUD all account types (not just admins) Per the assignment's instructions. --- src/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/App.hs b/src/App.hs index 6f52dabcc..07203d143 100644 --- a/src/App.hs +++ b/src/App.hs @@ -89,7 +89,7 @@ server config@T.Config{..} = createAccount (Nothing, T.Admin) -> throwError err401 { errBody = "Only admins can create Admin accounts" } (Just cookie, _) -> - adminsOnly cookie doCreateAccount + adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) doCreateAccount where doCreateAccount :: Handler NoContent doCreateAccount = do From fe609bbe5804be229a7e5c0d276654fb3e45179b Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 15:15:01 +0100 Subject: [PATCH 66/79] Support CRUDing records on Admin page TL;DR: - Prefer the more precise verbiage, "Accounts", to "Users" - Add username field to Trip instead of relying on session.username - Ensure that decodeRole can JD.fail for invalid inputs --- client/src/Admin.elm | 99 ++++++++++++++++++++------- client/src/Manager.elm | 10 ++- client/src/State.elm | 147 ++++++++++++++++++++++++++--------------- client/src/User.elm | 2 +- 4 files changed, 171 insertions(+), 87 deletions(-) diff --git a/client/src/Admin.elm b/client/src/Admin.elm index e8e33bde6..17155c1d8 100644 --- a/client/src/Admin.elm +++ b/client/src/Admin.elm @@ -1,21 +1,22 @@ module Admin exposing (render) +import Common +import Date import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) import RemoteData import State -import Common import Tailwind import UI import Utils -allUsers : State.Model -> Html State.Msg -allUsers model = - case model.users of +allTrips : State.Model -> Html State.Msg +allTrips model = + case model.trips of RemoteData.NotAsked -> - UI.absentData { handleFetch = State.AttemptGetUsers } + UI.absentData { handleFetch = State.AttemptGetTrips } RemoteData.Loading -> UI.paragraph "Loading..." @@ -24,14 +25,51 @@ allUsers model = UI.paragraph ("Error: " ++ Utils.explainHttpError e) RemoteData.Success xs -> - div [] - [ UI.header 3 "Admins" - , users xs.admin - , UI.header 3 "Managers" - , users xs.manager - , UI.header 3 "Users" - , users xs.user - ] + ul [] + (xs + |> List.map + (\trip -> + li [] + [ UI.paragraph (Date.toIsoString trip.startDate ++ " - " ++ Date.toIsoString trip.endDate ++ ", " ++ trip.username ++ " is going " ++ trip.destination) + , UI.textButton + { label = "delete" + , handleClick = State.AttemptDeleteTrip trip + } + ] + ) + ) + + +allUsers : State.Model -> Html State.Msg +allUsers model = + case model.accounts of + RemoteData.NotAsked -> + UI.absentData { handleFetch = State.AttemptGetAccounts } + + RemoteData.Loading -> + UI.paragraph "Loading..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + ul [] + (xs + |> List.map + (\account -> + li [] + [ UI.paragraph + (account.username + ++ " - " + ++ State.roleToString account.role + ) + , UI.textButton + { label = "delete" + , handleClick = State.AttemptDeleteAccount account.username + } + ] + ) + ) users : List String -> Html State.Msg @@ -45,7 +83,7 @@ users xs = , div [ [ "flex-1" ] |> Tailwind.use |> class ] [ UI.simpleButton { label = "Delete" - , handleClick = State.AttemptDeleteUser x + , handleClick = State.AttemptDeleteAccount x } ] ] @@ -63,21 +101,32 @@ render model = |> Tailwind.use |> class ] - [ UI.header 2 "Welcome back!" - , UI.simpleButton - { label = "Logout" - , handleClick = State.AttemptLogout - } + [ UI.header 2 "Welcome!" , div [] - [ UI.baseButton - { label = "Switch to users" - , handleClick = State.UpdateAdminTab State.Users - , enabled = not (model.adminTab == State.Users) - , extraClasses = [] + [ UI.textButton + { label = "Logout" + , handleClick = State.AttemptLogout } ] + , div [ [ "py-3" ] |> Tailwind.use |> class ] + [ case model.adminTab of + State.Accounts -> + UI.textButton + { label = "Switch to trips" + , handleClick = State.UpdateAdminTab State.Trips + } + + State.Trips -> + UI.textButton + { label = "Switch to accounts" + , handleClick = State.UpdateAdminTab State.Accounts + } + ] , case model.adminTab of - State.Users -> + State.Accounts -> allUsers model + + State.Trips -> + allTrips model , Common.allErrors model ] diff --git a/client/src/Manager.elm b/client/src/Manager.elm index 7cf5dc310..67cf94143 100644 --- a/client/src/Manager.elm +++ b/client/src/Manager.elm @@ -14,11 +14,8 @@ import Utils render : State.Model -> Html State.Msg render model = - case model.session of - Nothing -> - text "You are unauthorized to view this page." - - Just session -> + Common.withSession model + (\session -> div [ class ([ "container" @@ -30,10 +27,11 @@ render model = ] [ h1 [] [ UI.header 2 ("Welcome back, " ++ session.username ++ "!") - , UI.simpleButton + , UI.textButton { label = "Logout" , handleClick = State.AttemptLogout } , Common.allErrors model ] ] + ) diff --git a/client/src/State.elm b/client/src/State.elm index a8970df24..8898918cc 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -44,20 +44,21 @@ type Msg | LinkClicked Browser.UrlRequest | UrlChanged Url.Url -- Outbound network - | AttemptGetUsers + | AttemptGetAccounts + | AttemptGetTrips | AttemptSignUp | AttemptLogin | AttemptLogout - | AttemptDeleteUser String + | AttemptDeleteAccount String | AttemptCreateTrip Date.Date Date.Date - | AttemptDeleteTrip String Date.Date + | AttemptDeleteTrip Trip -- Inbound network - | GotUsers (WebData AllUsers) + | GotAccounts (WebData (List Account)) | GotTrips (WebData (List Trip)) | GotSignUp (Result Http.Error Session) | GotLogin (Result Http.Error Session) | GotLogout (Result Http.Error String) - | GotDeleteUser (Result Http.Error String) + | GotDeleteAccount (Result Http.Error String) | GotCreateTrip (Result Http.Error ()) | GotDeleteTrip (Result Http.Error ()) @@ -75,10 +76,9 @@ type Role | Admin -type alias AllUsers = - { user : List String - , manager : List String - , admin : List String +type alias Account = + { username : String + , role : Role } @@ -98,7 +98,8 @@ type alias Review = type AdminTab - = Users + = Accounts + | Trips type LoginTab @@ -107,7 +108,8 @@ type LoginTab type alias Trip = - { destination : String + { username : String + , destination : String , startDate : Date.Date , endDate : Date.Date , comment : String @@ -123,7 +125,7 @@ type alias Model = , email : String , password : String , role : Maybe Role - , users : WebData AllUsers + , accounts : WebData (List Account) , startDatePicker : DatePicker.DatePicker , endDatePicker : DatePicker.DatePicker , tripDestination : String @@ -191,8 +193,8 @@ decodeRole = "admin" -> JD.succeed Admin - _ -> - JD.succeed User + x -> + JD.fail ("Invalid input: " ++ x) in JD.string |> JD.andThen toRole @@ -298,12 +300,12 @@ deleteTrip { username, destination, startDate } = } -deleteUser : String -> Cmd Msg -deleteUser username = +deleteAccount : String -> Cmd Msg +deleteAccount username = Utils.deleteWithCredentials - { url = endpoint [ "user", username ] [] + { url = endpoint [ "accounts" ] [ UrlBuilder.string "username" username ] , body = Http.emptyBody - , expect = Http.expectString GotDeleteUser + , expect = Http.expectString GotDeleteAccount } @@ -336,8 +338,9 @@ fetchTrips = Http.expectJson (RemoteData.fromResult >> GotTrips) (JD.list - (JD.map4 + (JD.map5 Trip + (JD.field "username" JD.string) (JD.field "destination" JD.string) (JD.field "startDate" decodeDate) (JD.field "endDate" decodeDate) @@ -347,18 +350,19 @@ fetchTrips = } -fetchUsers : Cmd Msg -fetchUsers = +fetchAccounts : Cmd Msg +fetchAccounts = Utils.getWithCredentials - { url = endpoint [ "all-usernames" ] [] + { url = endpoint [ "accounts" ] [] , expect = Http.expectJson - (RemoteData.fromResult >> GotUsers) - (JD.map3 - AllUsers - (JD.field "user" (JD.list JD.string)) - (JD.field "manager" (JD.list JD.string)) - (JD.field "admin" (JD.list JD.string)) + (RemoteData.fromResult >> GotAccounts) + (JD.list + (JD.map2 + Account + (JD.field "username" JD.string) + (JD.field "role" decodeRole) + ) ) } @@ -424,7 +428,7 @@ prod _ url key = , email = "" , password = "" , role = Nothing - , users = RemoteData.NotAsked + , accounts = RemoteData.NotAsked , tripDestination = "" , tripStartDate = Nothing , tripEndDate = Nothing @@ -432,7 +436,7 @@ prod _ url key = , trips = RemoteData.NotAsked , startDatePicker = startDatePicker , endDatePicker = endDatePicker - , adminTab = Users + , adminTab = Accounts , loginTab = LoginForm , loginError = Nothing , logoutError = Nothing @@ -461,12 +465,14 @@ userHome flags url key = , session = Just { username = "mimi", role = User } , trips = RemoteData.Success - [ { destination = "Barcelona" + [ { username = "mimi" + , destination = "Barcelona" , startDate = Date.fromCalendarDate 2020 Time.Sep 25 , endDate = Date.fromCalendarDate 2020 Time.Oct 5 , comment = "Blah" } - , { destination = "Paris" + , { username = "mimi" + , destination = "Paris" , startDate = Date.fromCalendarDate 2021 Time.Jan 1 , endDate = Date.fromCalendarDate 2021 Time.Feb 1 , comment = "Bon voyage!" @@ -477,6 +483,34 @@ userHome flags url key = ) +managerHome : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +managerHome flags url key = + let + ( model, cmd ) = + prod flags url key + in + ( { model + | route = Just ManagerHome + , session = Just { username = "bill", role = Manager } + } + , cmd + ) + + +adminHome : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +adminHome flags url key = + let + ( model, cmd ) = + prod flags url key + in + ( { model + | route = Just AdminHome + , session = Just { username = "wpcarro", role = Admin } + } + , cmd + ) + + port printPage : () -> Cmd msg @@ -484,7 +518,7 @@ port printPage : () -> Cmd msg -} init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) init flags url key = - userHome flags url key + adminHome flags url key {-| Now that we have state, we need a function to change the state. @@ -625,17 +659,22 @@ update msg model = ( { model | url = url , route = route + , accounts = RemoteData.Loading } - , Cmd.none + , fetchAccounts ) Just AdminHome -> ( { model | url = url , route = route - , users = RemoteData.Loading + , accounts = RemoteData.Loading + , trips = RemoteData.Loading } - , Cmd.none + , Cmd.batch + [ fetchAccounts + , fetchTrips + ] ) _ -> @@ -647,20 +686,20 @@ update msg model = ) -- GET /accounts - AttemptGetUsers -> - ( { model | users = RemoteData.Loading }, fetchUsers ) + AttemptGetAccounts -> + ( { model | accounts = RemoteData.Loading }, fetchAccounts ) - GotUsers xs -> - ( { model | users = xs }, Cmd.none ) + GotAccounts xs -> + ( { model | accounts = xs }, Cmd.none ) -- DELETE /accounts - AttemptDeleteUser username -> - ( model, deleteUser username ) + AttemptDeleteAccount username -> + ( model, deleteAccount username ) - GotDeleteUser result -> + GotDeleteAccount result -> case result of Ok _ -> - ( model, fetchUsers ) + ( model, fetchAccounts ) Err e -> ( { model | deleteUserError = Just e } @@ -708,18 +747,13 @@ update msg model = ) -- DELETE /trips - AttemptDeleteTrip destination startDate -> + AttemptDeleteTrip trip -> ( model - , case model.session of - Nothing -> - Cmd.none - - Just session -> - deleteTrip - { username = session.username - , destination = destination - , startDate = startDate - } + , deleteTrip + { username = trip.username + , destination = trip.destination + , startDate = trip.startDate + } ) GotDeleteTrip result -> @@ -755,6 +789,9 @@ update msg model = ) -- GET /trips + AttemptGetTrips -> + ( { model | trips = RemoteData.Loading }, fetchTrips ) + GotTrips xs -> ( { model | trips = xs }, Cmd.none ) diff --git a/client/src/User.elm b/client/src/User.elm index 660c3aa7d..0c87e85bf 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -89,7 +89,7 @@ renderTrip trip = , UI.wrapNoPrint (UI.textButton { label = "Delete" - , handleClick = State.AttemptDeleteTrip trip.destination trip.startDate + , handleClick = State.AttemptDeleteTrip trip } ) ] From 25334080b9bcdf238f75069feb92fba65896da5e Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 16:07:35 +0100 Subject: [PATCH 67/79] Support POST /invite Allow Admin accounts to invite users to the application. --- src/API.hs | 4 ++++ src/App.hs | 36 +++++++++++++++++++++++++++++++----- src/Invitations.hs | 14 ++++++++++++++ src/Types.hs | 27 +++++++++++++++++++++++++++ src/init.sql | 8 ++++++++ 5 files changed, 84 insertions(+), 5 deletions(-) create mode 100644 src/Invitations.hs diff --git a/src/API.hs b/src/API.hs index 956e745b3..caf42727d 100644 --- a/src/API.hs +++ b/src/API.hs @@ -67,3 +67,7 @@ type API = :> SessionCookie :> ReqBody '[JSON] T.UnfreezeAccountRequest :> Post '[JSON] NoContent + :<|> "invite" + :> SessionCookie + :> ReqBody '[JSON] T.InviteUserRequest + :> Post '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index 07203d143..cec8a135b 100644 --- a/src/App.hs +++ b/src/App.hs @@ -29,6 +29,7 @@ import qualified Accounts as Accounts import qualified Auth as Auth import qualified Trips as Trips import qualified Sessions as Sessions +import qualified Invitations as Invitations import qualified LoginAttempts as LoginAttempts import qualified PendingAccounts as PendingAccounts -------------------------------------------------------------------------------- @@ -43,20 +44,32 @@ err429 = ServerError -- | Send an email to recipient, `to`, with a secret code. sendVerifyEmail :: T.Config - -> Text -> T.Username -> T.Email -> T.RegistrationSecret -> IO (Either Email.SendError Email.SendSuccess) -sendVerifyEmail T.Config{..} apiKey (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do - Email.send apiKey subject (cs body) email +sendVerifyEmail T.Config{..} (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do + Email.send mailgunAPIKey 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 - cs configServer ++ cs username ++ "&secret=" ++ secret + cs configServer ++ "/verify?username=" ++ cs username ++ "&secret=" ++ secret + +-- | Send an invitation email to recipient, `to`, with a secret code. +sendInviteEmail :: T.Config + -> T.Email + -> T.InvitationSecret + -> IO (Either Email.SendError Email.SendSuccess) +sendInviteEmail T.Config{..} email@(T.Email to) (T.InvitationSecret secretUUID) = do + Email.send mailgunAPIKey subject (cs body) email + where + subject = "You've been invited!" + body = + let secret = secretUUID |> UUID.toString in + cs configServer ++ "/accept-invitation?email=" ++ cs to ++ "&secret=" ++ secret server :: T.Config -> Server API server config@T.Config{..} = createAccount @@ -70,6 +83,7 @@ server config@T.Config{..} = createAccount :<|> login :<|> logout :<|> unfreezeAccount + :<|> inviteUser where -- Admit Admins + whatever the predicate `p` passes. adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) @@ -100,7 +114,7 @@ server config@T.Config{..} = createAccount createAccountRequestPassword createAccountRequestRole createAccountRequestEmail - liftIO $ sendVerifyEmail config mailgunAPIKey + liftIO $ sendVerifyEmail config createAccountRequestUsername createAccountRequestEmail secretUUID @@ -219,6 +233,18 @@ server config@T.Config{..} = createAccount liftIO $ LoginAttempts.reset dbFile unfreezeAccountRequestUsername pure NoContent + inviteUser :: T.SessionCookie + -> T.InviteUserRequest + -> Handler NoContent + inviteUser cookie T.InviteUserRequest{..} = adminsOnly cookie $ do + secretUUID <- liftIO $ T.InvitationSecret <$> Random.randomIO + liftIO $ Invitations.create dbFile + secretUUID + inviteUserRequestEmail + inviteUserRequestRole + liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID + pure NoContent + run :: T.Config -> IO () run config@T.Config{..} = Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server config) diff --git a/src/Invitations.hs b/src/Invitations.hs new file mode 100644 index 000000000..62038bb03 --- /dev/null +++ b/src/Invitations.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Invitations where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple + +import qualified Types as T +-------------------------------------------------------------------------------- + +create :: FilePath -> T.InvitationSecret -> T.Email -> T.Role -> IO () +create dbFile secret email role = withConnection dbFile $ \conn -> do + execute conn "INSERT INTO Invitations (email,role,secret) VALUES (?,?,?)" + (email, role, secret) diff --git a/src/Types.hs b/src/Types.hs index 54f3ec64e..7fe3f2b15 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -469,3 +469,30 @@ instance FromJSON UnfreezeAccountRequest where parseJSON = withObject "UnfreezeAccountRequest" $ \x -> do unfreezeAccountRequestUsername <- x .: "username" pure UnfreezeAccountRequest{..} + +data InviteUserRequest = InviteUserRequest + { inviteUserRequestEmail :: Email + , inviteUserRequestRole :: Role + } deriving (Eq, Show) + +instance FromJSON InviteUserRequest where + parseJSON = withObject "InviteUserRequest" $ \x -> do + inviteUserRequestEmail <- x .: "email" + inviteUserRequestRole <- x .: "role" + pure InviteUserRequest{..} + +newtype InvitationSecret = InvitationSecret UUID.UUID + deriving (Eq, Show) + +instance ToField InvitationSecret where + toField (InvitationSecret secretUUID) = + secretUUID |> UUID.toText |> SQLText + +instance FromField InvitationSecret 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 $ InvitationSecret x + _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" diff --git a/src/init.sql b/src/init.sql index b616fdece..b42753ae5 100644 --- a/src/init.sql +++ b/src/init.sql @@ -11,6 +11,7 @@ DROP TABLE IF EXISTS Trips; DROP TABLE IF EXISTS Sessions; DROP TABLE IF EXISTS LoginAttempts; DROP TABLE IF EXISTS PendingAccounts; +DROP TABLE IF EXISTS Invitations; CREATE TABLE Accounts ( username TEXT CHECK(LENGTH(username) > 0) NOT NULL, @@ -56,4 +57,11 @@ CREATE TABLE PendingAccounts ( PRIMARY KEY (username) ); +CREATE TABLE Invitations ( + email TEXT CHECK(LENGTH(email) > 0) NOT NULL UNIQUE, + role TEXT CHECK(role IN ('user', 'manager', 'admin')) NOT NULL, + secret TEXT CHECK(LENGTH(secret) == 36) NOT NULL, + PRIMARY KEY (email) +); + COMMIT; From e9e84f6a08c0711c498c7f1f0c9aefc39520c7a7 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 16:30:28 +0100 Subject: [PATCH 68/79] Support POST /accept-invitation Allow users to accept invitations that we email to them. TL;DR: - I learned how to write FromHttpApiData instances, which allows me to parse/validate data at the edges of my application; this substantially cleans up my Handler code. --- src/API.hs | 5 ++++- src/App.hs | 45 +++++++++++++++++++++++++++++---------------- src/Invitations.hs | 7 +++++++ src/Types.hs | 39 +++++++++++++++++++++++++++++++++++++-- 4 files changed, 77 insertions(+), 19 deletions(-) diff --git a/src/API.hs b/src/API.hs index caf42727d..3c311591c 100644 --- a/src/API.hs +++ b/src/API.hs @@ -21,7 +21,7 @@ type API = :> Post '[JSON] NoContent :<|> "verify" :> QueryParam' '[Required] "username" Text - :> QueryParam' '[Required] "secret" Text + :> QueryParam' '[Required] "secret" T.RegistrationSecret :> Get '[JSON] NoContent -- accounts: Read -- accounts: Update @@ -71,3 +71,6 @@ type API = :> SessionCookie :> ReqBody '[JSON] T.InviteUserRequest :> Post '[JSON] NoContent + :<|> "accept-invitation" + :> ReqBody '[JSON] T.AcceptInvitationRequest + :> Get '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index cec8a135b..d83f75e30 100644 --- a/src/App.hs +++ b/src/App.hs @@ -84,6 +84,7 @@ server config@T.Config{..} = createAccount :<|> logout :<|> unfreezeAccount :<|> inviteUser + :<|> acceptInvitation where -- Admit Admins + whatever the predicate `p` passes. adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) @@ -120,22 +121,18 @@ server config@T.Config{..} = createAccount 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" } + verifyAccount :: Text -> T.RegistrationSecret -> Handler NoContent + verifyAccount username 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 @@ -245,6 +242,22 @@ server config@T.Config{..} = createAccount liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID pure NoContent + acceptInvitation :: T.AcceptInvitationRequest -> Handler NoContent + acceptInvitation T.AcceptInvitationRequest{..} = do + mInvitation <- liftIO $ Invitations.get dbFile acceptInvitationRequestEmail + case mInvitation of + Nothing -> throwError err404 { errBody = "No invitation for email" } + Just T.Invitation{..} -> + if invitationSecret == acceptInvitationRequestSecret then do + liftIO $ Accounts.create dbFile + acceptInvitationRequestUsername + acceptInvitationRequestPassword + invitationEmail + invitationRole + pure NoContent + else + throwError err401 { errBody = "You are not providing a valid secret" } + run :: T.Config -> IO () run config@T.Config{..} = Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server config) diff --git a/src/Invitations.hs b/src/Invitations.hs index 62038bb03..0c700470f 100644 --- a/src/Invitations.hs +++ b/src/Invitations.hs @@ -12,3 +12,10 @@ create :: FilePath -> T.InvitationSecret -> T.Email -> T.Role -> IO () create dbFile secret email role = withConnection dbFile $ \conn -> do execute conn "INSERT INTO Invitations (email,role,secret) VALUES (?,?,?)" (email, role, secret) + +get :: FilePath -> T.Email -> IO (Maybe T.Invitation) +get dbFile email = withConnection dbFile $ \conn -> do + res <- query conn "SELECT email,role,secret FROM Invitations WHERE email = ?" (Only email) + case res of + [x] -> pure (Just x) + _ -> pure Nothing diff --git a/src/Types.hs b/src/Types.hs index 7fe3f2b15..235e8a6d0 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -401,7 +401,13 @@ instance FromHttpApiData SessionCookie where x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure newtype RegistrationSecret = RegistrationSecret UUID.UUID - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance FromHttpApiData RegistrationSecret where + parseQueryParam x = + case UUID.fromText x of + Nothing -> Left x + Just uuid -> Right (RegistrationSecret uuid) instance FromField RegistrationSecret where fromField field = @@ -482,7 +488,10 @@ instance FromJSON InviteUserRequest where pure InviteUserRequest{..} newtype InvitationSecret = InvitationSecret UUID.UUID - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance ToJSON InvitationSecret +instance FromJSON InvitationSecret instance ToField InvitationSecret where toField (InvitationSecret secretUUID) = @@ -496,3 +505,29 @@ instance FromField InvitationSecret where Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x) Just x -> Ok $ InvitationSecret x _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" + +data Invitation = Invitation + { invitationEmail :: Email + , invitationRole :: Role + , invitationSecret :: InvitationSecret + } deriving (Eq, Show) + +instance FromRow Invitation where + fromRow = Invitation <$> field + <*> field + <*> field + +data AcceptInvitationRequest = AcceptInvitationRequest + { acceptInvitationRequestUsername :: Username + , acceptInvitationRequestPassword :: ClearTextPassword + , acceptInvitationRequestEmail :: Email + , acceptInvitationRequestSecret :: InvitationSecret + } deriving (Eq, Show) + +instance FromJSON AcceptInvitationRequest where + parseJSON = withObject "AcceptInvitationRequest" $ \x -> do + acceptInvitationRequestUsername <- x .: "username" + acceptInvitationRequestPassword <- x .: "password" + acceptInvitationRequestEmail <- x .: "email" + acceptInvitationRequestSecret <- x .: "secret" + pure AcceptInvitationRequest{..} From 90d145189532b3691294ffb6d9326487942df4bc Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 17:45:34 +0100 Subject: [PATCH 69/79] Render " days until" for upcoming trips Per the assignment spec. --- client/src/User.elm | 61 +++++++++++++++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 19 deletions(-) diff --git a/client/src/User.elm b/client/src/User.elm index 0c87e85bf..84523ef59 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -71,20 +71,34 @@ createTrip model = ] -renderTrip : State.Trip -> Html State.Msg -renderTrip trip = +renderTrip : Date.Date -> State.Trip -> Html State.Msg +renderTrip today trip = li [ [ "py-2" ] |> Tailwind.use |> class ] - [ UI.paragraph - (Date.toIsoString trip.startDate - ++ " - " - ++ Date.toIsoString trip.endDate - ++ " -> " - ++ trip.destination - ) + [ if Date.compare today trip.startDate == GT then + UI.paragraph + (String.fromInt (Date.diff Date.Days trip.startDate today) + ++ " days until you're travelling to " + ++ trip.destination + ++ " for " + ++ String.fromInt + (Date.diff + Date.Days + trip.startDate + trip.endDate + ) + ++ " days." + ) + + else + UI.paragraph + (String.fromInt (Date.diff Date.Days today trip.endDate) + ++ " days ago you returned from your trip to " + ++ trip.destination + ) , UI.paragraph ("\"" ++ trip.comment ++ "\"") , UI.wrapNoPrint (UI.textButton @@ -98,7 +112,7 @@ renderTrip trip = trips : State.Model -> Html State.Msg trips model = div [] - [ UI.header 3 "Upcoming Trips" + [ UI.header 3 "Your Trips" , case model.trips of RemoteData.NotAsked -> UI.paragraph "Somehow we've reached the user home page without requesting your trips data. Please report this to our engineering team at bugs@tripplaner.tld" @@ -110,15 +124,24 @@ trips model = UI.paragraph ("Error: " ++ Utils.explainHttpError e) RemoteData.Success xs -> - div [ [ "mb-10" ] |> Tailwind.use |> class ] - [ ul [ [ "my-4" ] |> Tailwind.use |> class ] (xs |> List.map renderTrip) - , UI.wrapNoPrint - (UI.simpleButton - { label = "Print iternary" - , handleClick = State.PrintPage - } - ) - ] + case model.todaysDate of + Nothing -> + text "" + + Just today -> + div [ [ "mb-10" ] |> Tailwind.use |> class ] + [ ul [ [ "my-4" ] |> Tailwind.use |> class ] + (xs + |> List.sortWith (\x y -> Date.compare y.startDate x.startDate) + |> List.map (renderTrip today) + ) + , UI.wrapNoPrint + (UI.simpleButton + { label = "Print iternary" + , handleClick = State.PrintPage + } + ) + ] ] From 2632dc10fdf8dc6dcde91bea0820b2cb67957607 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 18:00:05 +0100 Subject: [PATCH 70/79] Ensure /accept-invitation is POST and not GET Debugged this bug! --- src/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/API.hs b/src/API.hs index 3c311591c..4c67896e2 100644 --- a/src/API.hs +++ b/src/API.hs @@ -73,4 +73,4 @@ type API = :> Post '[JSON] NoContent :<|> "accept-invitation" :> ReqBody '[JSON] T.AcceptInvitationRequest - :> Get '[JSON] NoContent + :> Post '[JSON] NoContent From a3d783025a8d2f9b57092809667fd93824e4cfa7 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 18:00:29 +0100 Subject: [PATCH 71/79] Add friendlier and more accurate instructions in invitation email Copy Example: To accept the invitation: POST /accept-invitation username= password= email=you@domain.tld secret=8c6b5719-7b1c-471c-bdea-7807b6c0866c --- src/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/App.hs b/src/App.hs index d83f75e30..e56e7c187 100644 --- a/src/App.hs +++ b/src/App.hs @@ -69,7 +69,7 @@ sendInviteEmail T.Config{..} email@(T.Email to) (T.InvitationSecret secretUUID) subject = "You've been invited!" body = let secret = secretUUID |> UUID.toString in - cs configServer ++ "/accept-invitation?email=" ++ cs to ++ "&secret=" ++ secret + "To accept the invitation: POST /accept-invitation username= password= email=" ++ cs to ++ " secret=" ++ secret server :: T.Config -> Server API server config@T.Config{..} = createAccount From 1d5cf2e4b57aa62e1867b6866e205bba8fdcc9a7 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 18:02:15 +0100 Subject: [PATCH 72/79] Support Admins inviting users from the client The title says it all. --- client/src/Admin.elm | 59 +++++++++++++++++++++++++++++++- client/src/State.elm | 81 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 139 insertions(+), 1 deletion(-) diff --git a/client/src/Admin.elm b/client/src/Admin.elm index 17155c1d8..d95609ee1 100644 --- a/client/src/Admin.elm +++ b/client/src/Admin.elm @@ -5,6 +5,7 @@ import Date import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) +import Maybe.Extra as ME import RemoteData import State import Tailwind @@ -12,6 +13,59 @@ import UI import Utils +roleToggle : State.Model -> State.Role -> Html State.Msg +roleToggle model role = + div [ [ "px-1", "inline" ] |> Tailwind.use |> class ] + [ UI.toggleButton + { toggled = model.inviteRole == Just role + , label = State.roleToString role + , handleEnable = State.UpdateInviteRole (Just role) + , handleDisable = State.UpdateInviteRole Nothing + } + ] + + +inviteUser : State.Model -> Html State.Msg +inviteUser model = + div [ [ "pb-6" ] |> Tailwind.use |> class ] + [ UI.header 3 "Invite a user" + , UI.textField + { handleInput = State.UpdateInviteEmail + , inputId = "invite-email" + , inputValue = model.inviteEmail + , pholder = "Email..." + } + , div [ [ "pt-4" ] |> Tailwind.use |> class ] + [ roleToggle model State.User + , roleToggle model State.Manager + , roleToggle model State.Admin + ] + , UI.baseButton + { enabled = + List.all + identity + [ String.length model.inviteEmail > 0 + , ME.isJust model.inviteRole + ] + , extraClasses = [ "my-4" ] + , label = + case model.inviteResponseStatus of + RemoteData.Loading -> + "Sending..." + + _ -> + "Send invitation" + , handleClick = + case model.inviteRole of + Nothing -> + State.DoNothing + + Just role -> + State.AttemptInviteUser role + } + ] + + allTrips : State.Model -> Html State.Msg allTrips model = case model.trips of @@ -124,7 +178,10 @@ render model = ] , case model.adminTab of State.Accounts -> - allUsers model + div [] + [ inviteUser model + , allUsers model + ] State.Trips -> allTrips model diff --git a/client/src/State.elm b/client/src/State.elm index 8898918cc..a38895a6c 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -40,6 +40,9 @@ type Msg | ClearErrors | ToggleLoginForm | PrintPage + | UpdateInviteEmail String + | UpdateInviteRole (Maybe Role) + | ReceiveTodaysDate Date.Date -- SPA | LinkClicked Browser.UrlRequest | UrlChanged Url.Url @@ -52,6 +55,7 @@ type Msg | AttemptDeleteAccount String | AttemptCreateTrip Date.Date Date.Date | AttemptDeleteTrip Trip + | AttemptInviteUser Role -- Inbound network | GotAccounts (WebData (List Account)) | GotTrips (WebData (List Trip)) @@ -61,6 +65,7 @@ type Msg | GotDeleteAccount (Result Http.Error String) | GotCreateTrip (Result Http.Error ()) | GotDeleteTrip (Result Http.Error ()) + | GotInviteUser (Result Http.Error ()) type Route @@ -121,6 +126,7 @@ type alias Model = , url : Url.Url , key : Nav.Key , session : Maybe Session + , todaysDate : Maybe Date.Date , username : String , email : String , password : String @@ -135,12 +141,16 @@ type alias Model = , trips : WebData (List Trip) , adminTab : AdminTab , loginTab : LoginTab + , inviteEmail : String + , inviteRole : Maybe Role + , inviteResponseStatus : WebData () , loginError : Maybe Http.Error , logoutError : Maybe Http.Error , signUpError : Maybe Http.Error , deleteUserError : Maybe Http.Error , createTripError : Maybe Http.Error , deleteTripError : Maybe Http.Error + , inviteUserError : Maybe Http.Error } @@ -151,6 +161,7 @@ allErrors model = , ( model.signUpError, "Error attempting to create your account" ) , ( model.deleteUserError, "Error attempting to delete a user" ) , ( model.createTripError, "Error attempting to create a trip" ) + , ( model.inviteUserError, "Error attempting to invite a user" ) ] @@ -178,6 +189,19 @@ endpoint = UrlBuilder.crossOrigin Shared.serverOrigin +encodeRole : Role -> JE.Value +encodeRole x = + case x of + User -> + JE.string "user" + + Manager -> + JE.string "manager" + + Admin -> + JE.string "admin" + + decodeRole : JD.Decoder Role decodeRole = let @@ -254,6 +278,21 @@ signUp { username, email, password } = } +inviteUser : { email : String, role : Role } -> Cmd Msg +inviteUser { email, role } = + Utils.postWithCredentials + { url = endpoint [ "invite" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "email", JE.string email ) + , ( "role", encodeRole role ) + ] + ) + , expect = Http.expectWhatever GotInviteUser + } + + createTrip : { username : String , destination : String @@ -424,6 +463,7 @@ prod _ url key = , url = url , key = key , session = Nothing + , todaysDate = Nothing , username = "" , email = "" , password = "" @@ -438,16 +478,21 @@ prod _ url key = , endDatePicker = endDatePicker , adminTab = Accounts , loginTab = LoginForm + , inviteEmail = "" + , inviteRole = Nothing + , inviteResponseStatus = RemoteData.NotAsked , loginError = Nothing , logoutError = Nothing , signUpError = Nothing , deleteUserError = Nothing , createTripError = Nothing , deleteTripError = Nothing + , inviteUserError = Nothing } , Cmd.batch [ Cmd.map UpdateTripStartDate startDatePickerCmd , Cmd.map UpdateTripEndDate endDatePickerCmd + , Date.today |> Task.perform ReceiveTodaysDate ] ) @@ -632,6 +677,15 @@ update msg model = PrintPage -> ( model, printPage () ) + UpdateInviteEmail x -> + ( { model | inviteEmail = x }, Cmd.none ) + + UpdateInviteRole mRole -> + ( { model | inviteRole = mRole }, Cmd.none ) + + ReceiveTodaysDate date -> + ( { model | todaysDate = Just date }, Cmd.none ) + LinkClicked urlRequest -> case urlRequest of Browser.Internal url -> @@ -766,6 +820,33 @@ update msg model = , sleepAndClearErrors ) + AttemptInviteUser role -> + ( { model | inviteResponseStatus = RemoteData.Loading } + , inviteUser + { email = model.inviteEmail + , role = role + } + ) + + GotInviteUser result -> + case result of + Ok _ -> + ( { model + | inviteEmail = "" + , inviteRole = Nothing + , inviteResponseStatus = RemoteData.Success () + } + , Cmd.none + ) + + Err x -> + ( { model + | inviteUserError = Just x + , inviteResponseStatus = RemoteData.Failure x + } + , sleepAndClearErrors + ) + -- POST /accounts AttemptSignUp -> ( model From 0cb9642a8acdd7d6a7a63eba3ccd98d0238a0bcb Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 19:44:23 +0100 Subject: [PATCH 73/79] Use valid dates for Trips.endDate in trips.csv TL;DR: My trips.csv had invalid dates for the endDate column. "2020-15-30" is an "invalid date" (according to FromField instance for Calendar.Day) bc 15 is not a valid month (i.e. [1,12]). @dmjio helped me take a look. When we poked around the SQL, we discovered: ```sql SELECT endDate FROM TRIPS; -- shows three records SELECT date(endDate) FROM TRIPS; -- shows two records ``` --- data/trips.csv | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/data/trips.csv b/data/trips.csv index 3377efeba..a583c750f 100644 --- a/data/trips.csv +++ b/data/trips.csv @@ -1,3 +1,3 @@ -mimi,Rome,2020-08-10,2020-15-30,Heading home before the upcoming trip with Panarea. -mimi,Panarea,2020-08-15,2020-05-30,Exciting upcoming trip with Matt and Sarah! -mimi,London,2020-08-30,2020-08-30,Heading back to London... \ No newline at end of file +mimi,Rome,2020-08-10,2020-08-12,Heading home before the upcoming trip with Panarea. +mimi,Panarea,2020-08-15,2020-08-28,Exciting upcoming trip with Matt and Sarah! +mimi,London,2020-08-30,2020-09-15,Heading back to London... \ No newline at end of file From 239ff24c95458fdff0706b99b8dab9d2fc8c8386 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 19:50:28 +0100 Subject: [PATCH 74/79] Use ORDER BY to sort the response for GET /trips SQL is quite useful. --- src/Trips.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Trips.hs b/src/Trips.hs index 022631219..f90740363 100644 --- a/src/Trips.hs +++ b/src/Trips.hs @@ -33,10 +33,10 @@ delete dbFile tripKey = -- | Return a list of all of the trips in `dbFile`. listAll :: FilePath -> IO [T.Trip] listAll dbFile = withConnection dbFile $ \conn -> - query_ conn "SELECT username,destination,startDate,endDate,comment FROM Trips" + query_ conn "SELECT username,destination,startDate,endDate,comment FROM Trips ORDER BY date(startDate) ASC" -- | Return a list of all of the trips in `dbFile`. list :: FilePath -> T.Username -> IO [T.Trip] list dbFile username = withConnection dbFile $ \conn -> - query conn "SELECT username,destination,startDate,endDate,comment FROM Trips WHERE username = ?" + query conn "SELECT username,destination,startDate,endDate,comment FROM Trips WHERE username = ? ORDER BY date(startDate) ASC" (Only username) From c2419cd9127c0077561c6f2c4c801998d231cc41 Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 20:56:29 +0100 Subject: [PATCH 75/79] Support updating trips from the client Edit existing trips. --- client/src/State.elm | 99 ++++++++++++++++++++++++++++++++++++++++++-- client/src/User.elm | 75 ++++++++++++++++++++++++++++++++- client/src/Utils.elm | 18 ++++++++ 3 files changed, 187 insertions(+), 5 deletions(-) diff --git a/client/src/State.elm b/client/src/State.elm index a38895a6c..110fb72a7 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -9,6 +9,7 @@ import Http import Json.Decode as JD import Json.Decode.Extra as JDE import Json.Encode as JE +import Json.Encode.Extra as JEE import Process import RemoteData exposing (WebData) import Shared @@ -37,12 +38,16 @@ type Msg | UpdateTripStartDate DatePicker.Msg | UpdateTripEndDate DatePicker.Msg | UpdateTripComment String + | UpdateEditTripDestination String + | UpdateEditTripComment String | ClearErrors | ToggleLoginForm | PrintPage | UpdateInviteEmail String | UpdateInviteRole (Maybe Role) | ReceiveTodaysDate Date.Date + | EditTrip Trip + | CancelEditTrip -- SPA | LinkClicked Browser.UrlRequest | UrlChanged Url.Url @@ -56,6 +61,7 @@ type Msg | AttemptCreateTrip Date.Date Date.Date | AttemptDeleteTrip Trip | AttemptInviteUser Role + | AttemptUpdateTrip TripPK Trip -- Inbound network | GotAccounts (WebData (List Account)) | GotTrips (WebData (List Trip)) @@ -66,6 +72,7 @@ type Msg | GotCreateTrip (Result Http.Error ()) | GotDeleteTrip (Result Http.Error ()) | GotInviteUser (Result Http.Error ()) + | GotUpdateTrip (Result Http.Error ()) type Route @@ -121,6 +128,13 @@ type alias Trip = } +type alias TripPK = + { username : String + , destination : String + , startDate : Date.Date + } + + type alias Model = { route : Maybe Route , url : Url.Url @@ -139,11 +153,15 @@ type alias Model = , tripEndDate : Maybe Date.Date , tripComment : String , trips : WebData (List Trip) + , editingTrip : Maybe Trip + , editTripDestination : String + , editTripComment : String , adminTab : AdminTab , loginTab : LoginTab , inviteEmail : String , inviteRole : Maybe Role , inviteResponseStatus : WebData () + , updateTripStatus : WebData () , loginError : Maybe Http.Error , logoutError : Maybe Http.Error , signUpError : Maybe Http.Error @@ -278,6 +296,24 @@ signUp { username, email, password } = } +updateTrip : TripPK -> Trip -> Cmd Msg +updateTrip tripKey trip = + Utils.putWithCredentials + { url = endpoint [ "trips" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "tripKey", encodeTripKey tripKey ) + , ( "destination", JE.string trip.destination ) + , ( "startDate", encodeDate trip.startDate ) + , ( "endDate", encodeDate trip.endDate ) + , ( "comment", JE.string trip.comment ) + ] + ) + , expect = Http.expectWhatever GotUpdateTrip + } + + inviteUser : { email : String, role : Role } -> Cmd Msg inviteUser { email, role } = Utils.postWithCredentials @@ -359,6 +395,15 @@ decodeReview = (JD.field "timestamp" JD.string) +encodeTripKey : TripPK -> JE.Value +encodeTripKey tripKey = + JE.object + [ ( "username", JE.string tripKey.username ) + , ( "destination", JE.string tripKey.destination ) + , ( "startDate", encodeDate tripKey.startDate ) + ] + + encodeDate : Date.Date -> JE.Value encodeDate date = date |> Date.toIsoString |> JE.string @@ -474,6 +519,9 @@ prod _ url key = , tripEndDate = Nothing , tripComment = "" , trips = RemoteData.NotAsked + , editingTrip = Nothing + , editTripDestination = "" + , editTripComment = "" , startDatePicker = startDatePicker , endDatePicker = endDatePicker , adminTab = Accounts @@ -481,6 +529,7 @@ prod _ url key = , inviteEmail = "" , inviteRole = Nothing , inviteResponseStatus = RemoteData.NotAsked + , updateTripStatus = RemoteData.NotAsked , loginError = Nothing , logoutError = Nothing , signUpError = Nothing @@ -563,7 +612,7 @@ port printPage : () -> Cmd msg -} init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) init flags url key = - adminHome flags url key + prod flags url key {-| Now that we have state, we need a function to change the state. @@ -650,6 +699,12 @@ update msg model = UpdateTripComment x -> ( { model | tripComment = x }, Cmd.none ) + UpdateEditTripDestination x -> + ( { model | editTripDestination = x }, Cmd.none ) + + UpdateEditTripComment x -> + ( { model | editTripComment = x }, Cmd.none ) + ClearErrors -> ( { model | loginError = Nothing @@ -686,6 +741,24 @@ update msg model = ReceiveTodaysDate date -> ( { model | todaysDate = Just date }, Cmd.none ) + EditTrip trip -> + ( { model + | editingTrip = Just trip + , editTripDestination = trip.destination + , editTripComment = trip.comment + } + , Cmd.none + ) + + CancelEditTrip -> + ( { model + | editingTrip = Nothing + , editTripDestination = "" + , editTripComment = "" + } + , Cmd.none + ) + LinkClicked urlRequest -> case urlRequest of Browser.Internal url -> @@ -839,14 +912,32 @@ update msg model = , Cmd.none ) - Err x -> + Err e -> ( { model - | inviteUserError = Just x - , inviteResponseStatus = RemoteData.Failure x + | inviteUserError = Just e + , inviteResponseStatus = RemoteData.Failure e } , sleepAndClearErrors ) + -- PATCH /trips + AttemptUpdateTrip tripKey trip -> + ( { model | updateTripStatus = RemoteData.Loading } + , updateTrip tripKey trip + ) + + GotUpdateTrip result -> + case result of + Ok _ -> + ( { model | updateTripStatus = RemoteData.Success () } + , fetchTrips + ) + + Err e -> + ( { model | updateTripStatus = RemoteData.Failure e } + , Cmd.none + ) + -- POST /accounts AttemptSignUp -> ( model diff --git a/client/src/User.elm b/client/src/User.elm index 84523ef59..87871b78d 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -71,6 +71,61 @@ createTrip model = ] +renderEditTrip : State.Model -> State.Trip -> Html State.Msg +renderEditTrip model trip = + li [] + [ div [] + [ UI.textField + { handleInput = State.UpdateEditTripDestination + , inputId = "edit-trip-destination" + , inputValue = model.editTripDestination + , pholder = "Destination" + } + , UI.textField + { handleInput = State.UpdateEditTripComment + , inputId = "edit-trip-comment" + , inputValue = model.editTripComment + , pholder = "Comment" + } + ] + , div [] + [ UI.baseButton + { enabled = + case model.updateTripStatus of + RemoteData.Loading -> + False + + _ -> + True + , extraClasses = [] + , label = + case model.updateTripStatus of + RemoteData.Loading -> + "Saving..." + + _ -> + "Save" + , handleClick = + State.AttemptUpdateTrip + { username = trip.username + , destination = trip.destination + , startDate = trip.startDate + } + { username = trip.username + , destination = model.editTripDestination + , startDate = trip.startDate + , endDate = trip.endDate + , comment = model.editTripComment + } + } + , UI.simpleButton + { label = "Cancel" + , handleClick = State.CancelEditTrip + } + ] + ] + + renderTrip : Date.Date -> State.Trip -> Html State.Msg renderTrip today trip = li @@ -100,6 +155,12 @@ renderTrip today trip = ++ trip.destination ) , UI.paragraph ("\"" ++ trip.comment ++ "\"") + , UI.wrapNoPrint + (UI.textButton + { label = "Edit" + , handleClick = State.EditTrip trip + } + ) , UI.wrapNoPrint (UI.textButton { label = "Delete" @@ -133,7 +194,19 @@ trips model = [ ul [ [ "my-4" ] |> Tailwind.use |> class ] (xs |> List.sortWith (\x y -> Date.compare y.startDate x.startDate) - |> List.map (renderTrip today) + |> List.map + (\trip -> + case model.editingTrip of + Nothing -> + renderTrip today trip + + Just x -> + if x == trip then + renderEditTrip model trip + + else + renderTrip today trip + ) ) , UI.wrapNoPrint (UI.simpleButton diff --git a/client/src/Utils.elm b/client/src/Utils.elm index 28f15fb5c..60343cd87 100644 --- a/client/src/Utils.elm +++ b/client/src/Utils.elm @@ -77,6 +77,24 @@ deleteWithCredentials { url, body, expect } = , expect = expect } +putWithCredentials : + { url : String + , body : Http.Body + , expect : Http.Expect msg + } + -> Cmd msg +putWithCredentials { url, body, expect } = + Http.riskyRequest + { url = url + , headers = [ Http.header "Origin" Shared.clientOrigin ] + , method = "PUT" + , timeout = Nothing + , tracker = Nothing + , body = body + , expect = expect + } + + formatTime : Time.Posix -> String formatTime ts = From d6b91b93cbb42170249eb17eb7d0cb1c1a31f44a Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 21:02:22 +0100 Subject: [PATCH 76/79] Allow managers to delete users Borrow the allUsers component TODO: Move many of these CRUD tables into Common and DRY-up usages across User, Admin, Manager. --- client/src/Manager.elm | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/client/src/Manager.elm b/client/src/Manager.elm index 67cf94143..cd15c99a3 100644 --- a/client/src/Manager.elm +++ b/client/src/Manager.elm @@ -12,6 +12,38 @@ import UI import Utils +allUsers : State.Model -> Html State.Msg +allUsers model = + case model.accounts of + RemoteData.NotAsked -> + UI.absentData { handleFetch = State.AttemptGetAccounts } + + RemoteData.Loading -> + UI.paragraph "Loading..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + ul [] + (xs + |> List.map + (\account -> + li [] + [ UI.paragraph + (account.username + ++ " - " + ++ State.roleToString account.role + ) + , UI.textButton + { label = "delete" + , handleClick = State.AttemptDeleteAccount account.username + } + ] + ) + ) + + render : State.Model -> Html State.Msg render model = Common.withSession model @@ -31,6 +63,7 @@ render model = { label = "Logout" , handleClick = State.AttemptLogout } + , allUsers model , Common.allErrors model ] ] From b9ed4a2dc170a3a4b6c1095cdfc79e49292f315d Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 21:27:08 +0100 Subject: [PATCH 77/79] Partially support federated login Two things: 1. I've never attempted to support this before. 2. It seems surprisingly and perhaps deceptively simpler than what I expected. I'm unsure what to do once Google's API authenticates the user. I currently look-up the user's role, trips, etc. using their email address. The role is stored in the Accounts table alongside username, email, password. I will speak with the interviewer tomorrow about this. --- client/index.html | 26 +++++++++++++------------- client/src/Login.elm | 33 ++++++++++++++++++++++++++++++--- client/src/State.elm | 14 ++++++++++++++ client/src/UI.elm | 3 ++- 4 files changed, 59 insertions(+), 17 deletions(-) diff --git a/client/index.html b/client/index.html index df63ffa06..9e6cef70d 100644 --- a/client/index.html +++ b/client/index.html @@ -13,19 +13,7 @@
diff --git a/client/src/Login.elm b/client/src/Login.elm index 083c47056..b1a436098 100644 --- a/client/src/Login.elm +++ b/client/src/Login.elm @@ -10,6 +10,16 @@ import UI import Utils +googleSignIn : Html State.Msg +googleSignIn = + div + [ class "g-signin2" + , attribute "onsuccess" "onSignIn" + , onClick State.GoogleSignIn + ] + [] + + loginForm : State.Model -> Html State.Msg loginForm model = div @@ -111,11 +121,28 @@ loginForm model = ] , case model.loginTab of State.LoginForm -> - UI.simpleButton { handleClick = State.AttemptLogin, label = "Login" } + div [ [ "flex", "space-around" ] |> Tailwind.use |> class ] + [ UI.simpleButton + { handleClick = State.AttemptLogin + , label = "Login" + } + , div [ [ "pl-4" ] |> Tailwind.use |> class ] [ googleSignIn ] + ] State.SignUpForm -> - if String.length model.username > 0 && String.length model.email > 0 && String.length model.password > 0 then - UI.simpleButton { handleClick = State.AttemptSignUp, label = "Sign up" } + if + List.all identity + [ String.length model.username > 0 + , String.length model.email > 0 + , String.length model.password > 0 + ] + then + div [] + [ UI.simpleButton + { handleClick = State.AttemptSignUp + , label = "Sign up" + } + ] else UI.disabledButton { label = "Sign up" } diff --git a/client/src/State.elm b/client/src/State.elm index 110fb72a7..b3f78bb16 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -43,6 +43,8 @@ type Msg | ClearErrors | ToggleLoginForm | PrintPage + | GoogleSignIn + | GoogleSignOut | UpdateInviteEmail String | UpdateInviteRole (Maybe Role) | ReceiveTodaysDate Date.Date @@ -608,6 +610,12 @@ adminHome flags url key = port printPage : () -> Cmd msg +port googleSignIn : () -> Cmd msg + + +port googleSignOut : () -> Cmd msg + + {-| The initial state for the application. -} init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) @@ -732,6 +740,12 @@ update msg model = PrintPage -> ( model, printPage () ) + GoogleSignIn -> + ( model, googleSignIn () ) + + GoogleSignOut -> + ( model, googleSignOut () ) + UpdateInviteEmail x -> ( { model | inviteEmail = x }, Cmd.none ) diff --git a/client/src/UI.elm b/client/src/UI.elm index f959b0cc7..7f8f37979 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -98,7 +98,8 @@ baseButton { label, enabled, handleClick, extraClasses } = "cursor-not-allowed" , "text-white" , "font-bold" - , "py-2" + , "py-1" + , "shadow-lg" , "px-4" , "rounded" , "focus:outline-none" From 9a19942c037ec62700c41c235154ff38816c0a3a Mon Sep 17 00:00:00 2001 From: William Carroll Date: Mon, 3 Aug 2020 11:37:57 +0100 Subject: [PATCH 78/79] Add .ghci configuration file Create a project-local .ghci file to define sensible defaults (e.g. -Wincomplete-patterns). TODO: Discover more GHC options to put in this file. I would prefer to keep this at the project root, but because I'm running the project from the src directory, I need to keep .ghci there. --- src/.ghci | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 src/.ghci diff --git a/src/.ghci b/src/.ghci new file mode 100644 index 000000000..f189fd0be --- /dev/null +++ b/src/.ghci @@ -0,0 +1,2 @@ +:set prompt "> " +:set -Wincomplete-patterns From ee8e75231cd9d3d4aa3ffbbfa0e3b8511712e1ee Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 4 Aug 2020 09:19:48 +0100 Subject: [PATCH 79/79] Set -Wall and fix warnings I think setting -Wall is a sensible default and @dmjio confirmed this. After putting this in my project's .ghci file, a few dozen warnings emerged. This commit changes the code that causes the warnings. --- src/.ghci | 2 +- src/App.hs | 18 +++++++++--------- src/Auth.hs | 8 +------- src/Email.hs | 2 +- src/Sessions.hs | 2 +- src/Types.hs | 50 ++++++++++++++++++++++++------------------------- src/Utils.hs | 1 + 7 files changed, 38 insertions(+), 45 deletions(-) diff --git a/src/.ghci b/src/.ghci index f189fd0be..efc88e630 100644 --- a/src/.ghci +++ b/src/.ghci @@ -1,2 +1,2 @@ :set prompt "> " -:set -Wincomplete-patterns +:set -Wall diff --git a/src/App.hs b/src/App.hs index e56e7c187..6a7de73a8 100644 --- a/src/App.hs +++ b/src/App.hs @@ -11,7 +11,6 @@ import Control.Monad.IO.Class (liftIO) import Data.String.Conversions (cs) import Data.Text (Text) import Servant -import Servant.Server.Internal.ServerError import API import Utils import Web.Cookie @@ -20,10 +19,7 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Cors as Cors 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 -import qualified Data.UUID.V4 as UUID import qualified Types as T import qualified Accounts as Accounts import qualified Auth as Auth @@ -48,7 +44,7 @@ sendVerifyEmail :: T.Config -> T.Email -> T.RegistrationSecret -> IO (Either Email.SendError Email.SendSuccess) -sendVerifyEmail T.Config{..} (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do +sendVerifyEmail T.Config{..} (T.Username username) email (T.RegistrationSecret secretUUID) = do Email.send mailgunAPIKey subject (cs body) email where subject = "Please confirm your account" @@ -115,11 +111,13 @@ server config@T.Config{..} = createAccount createAccountRequestPassword createAccountRequestRole createAccountRequestEmail - liftIO $ sendVerifyEmail config + res <- liftIO $ sendVerifyEmail config createAccountRequestUsername createAccountRequestEmail secretUUID - pure NoContent + case res of + Left _ -> undefined + Right _ -> pure NoContent verifyAccount :: Text -> T.RegistrationSecret -> Handler NoContent verifyAccount username secretUUID = do @@ -239,8 +237,10 @@ server config@T.Config{..} = createAccount secretUUID inviteUserRequestEmail inviteUserRequestRole - liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID - pure NoContent + res <- liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID + case res of + Left _ -> undefined + Right _ -> pure NoContent acceptInvitation :: T.AcceptInvitationRequest -> Handler NoContent acceptInvitation T.AcceptInvitationRequest{..} = do diff --git a/src/Auth.hs b/src/Auth.hs index 4962ce50a..f1bff2325 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -4,19 +4,13 @@ module Auth where -------------------------------------------------------------------------------- import Control.Monad.IO.Class (liftIO) -import Data.String.Conversions (cs) -import Database.SQLite.Simple -import Utils import Web.Cookie import Servant -import Servant.Server.Internal.ServerError import qualified Data.UUID as UUID -import qualified Web.Cookie as WC import qualified Sessions as Sessions import qualified Accounts as Accounts import qualified Types as T -import qualified Data.ByteString.Lazy as LBS -------------------------------------------------------------------------------- -- | Return the UUID from a Session cookie. @@ -28,7 +22,7 @@ uuidFromCookie (T.SessionCookie cookies) = do -- | Attempt to return the account associated with `cookie`. accountFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Account) -accountFromCookie dbFile cookie = withConnection dbFile $ \conn -> do +accountFromCookie dbFile cookie = case uuidFromCookie cookie of Nothing -> pure Nothing Just uuid -> do diff --git a/src/Email.hs b/src/Email.hs index 439b15d0e..2dac0973b 100644 --- a/src/Email.hs +++ b/src/Email.hs @@ -29,7 +29,7 @@ send apiKey subject body (T.Email to) = do res <- MG.sendEmail ctx x case res of Left e -> pure $ Left (ResponseError e) - Right x -> pure $ Right (SendSuccess x) + Right y -> pure $ Right (SendSuccess y) where ctx = MG.HailgunContext { MG.hailgunDomain = "sandboxda5038873f924b50af2f82a0f05cffdf.mailgun.org" , MG.hailgunApiKey = cs apiKey diff --git a/src/Sessions.hs b/src/Sessions.hs index f5b2f6f41..713059a38 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -58,7 +58,7 @@ delete dbFile uuid = withConnection dbFile $ \conn -> -- | Find or create a session in the Sessions table. If a session exists, -- refresh the token's validity. findOrCreate :: FilePath -> T.Account -> IO T.SessionUUID -findOrCreate dbFile account = withConnection dbFile $ \conn -> +findOrCreate dbFile account = let username = T.accountUsername account in do mSession <- find dbFile username case mSession of diff --git a/src/Types.hs b/src/Types.hs index 235e8a6d0..00fa09ccc 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,7 +10,6 @@ import Data.Aeson import Utils import Data.Text import Data.Typeable -import Data.String.Conversions (cs) import Database.SQLite.Simple import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField @@ -22,7 +21,6 @@ import System.Envy (FromEnv, fromEnv, env) import Crypto.Random.Types (MonadRandom) import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Format as TF import qualified Crypto.KDF.BCrypt as BC import qualified Data.Time.Clock as Clock import qualified Data.ByteString.Char8 as B @@ -50,10 +48,10 @@ instance FromEnv Config where -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b -forNewtype wrapper field = - case fieldData field of +forNewtype wrapper y = + case fieldData y of (SQLText x) -> Ok (wrapper x) - x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x) + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) newtype Username = Username Text deriving (Eq, Show, Generic) @@ -74,10 +72,10 @@ instance ToField HashedPassword where toField (HashedPassword x) = SQLText (TE.decodeUtf8 x) instance FromField HashedPassword where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok - x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x) + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) newtype ClearTextPassword = ClearTextPassword Text deriving (Eq, Show, Generic) @@ -125,12 +123,12 @@ instance ToField Role where toField Admin = SQLText "admin" instance FromField Role where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText "user") -> Ok RegularUser (SQLText "manager") -> Ok Manager (SQLText "admin") -> Ok Admin - x -> returnError ConversionFailed field ("We expected user, manager, admin, but we received: " ++ show x) + x -> returnError ConversionFailed y ("We expected user, manager, admin, but we received: " ++ show x) -- TODO(wpcarro): Prefer Data.ByteString instead of Text newtype ProfilePicture = ProfilePicture Text @@ -356,13 +354,13 @@ newtype SessionUUID = SessionUUID UUID.UUID deriving (Eq, Show, Generic) instance FromField SessionUUID where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> case UUID.fromText x of - Nothing -> returnError ConversionFailed field ("Could not convert to UUID: " ++ show x) - Just x -> Ok $ SessionUUID x - _ -> returnError ConversionFailed field "Expected SQLText for SessionUUID, but we received" + Nothing -> returnError ConversionFailed y ("Could not convert to UUID: " ++ show x) + Just uuid -> Ok $ SessionUUID uuid + _ -> returnError ConversionFailed y "Expected SQLText for SessionUUID, but we received" instance ToField SessionUUID where toField (SessionUUID uuid) = @@ -410,13 +408,13 @@ instance FromHttpApiData RegistrationSecret where Just uuid -> Right (RegistrationSecret uuid) instance FromField RegistrationSecret where - fromField field = - case fieldData field of + fromField y = + case fieldData y 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" + Nothing -> returnError ConversionFailed y ("Could not convert text to UUID: " ++ show x) + Just uuid -> Ok $ RegistrationSecret uuid + _ -> returnError ConversionFailed y "Field data is not SQLText, which is what we expect" instance ToField RegistrationSecret where toField (RegistrationSecret secretUUID) = @@ -498,13 +496,13 @@ instance ToField InvitationSecret where secretUUID |> UUID.toText |> SQLText instance FromField InvitationSecret where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> case UUID.fromText x of - Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x) - Just x -> Ok $ InvitationSecret x - _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" + Nothing -> returnError ConversionFailed y ("Could not convert text to UUID: " ++ show x) + Just z -> Ok $ InvitationSecret z + _ -> returnError ConversionFailed y "Field data is not SQLText, which is what we expect" data Invitation = Invitation { invitationEmail :: Email diff --git a/src/Utils.hs b/src/Utils.hs index 78ee93ec9..48c33af07 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -5,4 +5,5 @@ import Data.Function ((&)) -------------------------------------------------------------------------------- -- | Prefer this operator to the ampersand for stylistic reasons. +(|>) :: a -> (a -> b) -> b (|>) = (&)