diff options
Diffstat (limited to 'users/wpcarro/assessments/tt')
42 files changed, 4004 insertions, 0 deletions
diff --git a/users/wpcarro/assessments/tt/.gitignore b/users/wpcarro/assessments/tt/.gitignore new file mode 100644 index 000000000000..d4d62d436b26 --- /dev/null +++ b/users/wpcarro/assessments/tt/.gitignore @@ -0,0 +1,6 @@ +.envrc +*.db +*.sqlite3 +!populate.sqlite3 +*.db-shm +*.db-wal \ No newline at end of file diff --git a/users/wpcarro/assessments/tt/README.md b/users/wpcarro/assessments/tt/README.md new file mode 100644 index 000000000000..0231ef3ab8a4 --- /dev/null +++ b/users/wpcarro/assessments/tt/README.md @@ -0,0 +1,50 @@ +# TT + +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: + +```shell +$ sqlite3 db.sqlite3 +``` + +Populate the database with: + +``` +sqlite3> .read populate.sqlite3 +``` + +You can verify that everything is setup with: + +``` +sqlite3> .tables +sqlite3> .schema +sqlite3> SELECT * FROM Accounts; +sqlite3> SELECT * FROM Trips; +``` diff --git a/users/wpcarro/assessments/tt/client/.gitignore b/users/wpcarro/assessments/tt/client/.gitignore new file mode 100644 index 000000000000..1cb4f3034cc3 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/.gitignore @@ -0,0 +1,3 @@ +/elm-stuff +/Main.min.js +/output.css diff --git a/users/wpcarro/assessments/tt/client/README.md b/users/wpcarro/assessments/tt/client/README.md new file mode 100644 index 000000000000..04804ad94fac --- /dev/null +++ b/users/wpcarro/assessments/tt/client/README.md @@ -0,0 +1,18 @@ +# 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 +$ npx tailwindcss build index.css -o output.css +$ elm-live -- src/Main.elm --output=Main.min.js +``` + +You can now view your web client at `http://localhost:8000`! diff --git a/users/wpcarro/assessments/tt/client/dir-locals.nix b/users/wpcarro/assessments/tt/client/dir-locals.nix new file mode 100644 index 000000000000..5c3ae08870b0 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/dir-locals.nix @@ -0,0 +1,3 @@ +let + briefcase = import /home/wpcarro/briefcase {}; +in briefcase.utils.nixBufferFromShell ./shell.nix diff --git a/users/wpcarro/assessments/tt/client/elm.json b/users/wpcarro/assessments/tt/client/elm.json new file mode 100644 index 000000000000..c4095e118e24 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/elm.json @@ -0,0 +1,40 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "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", + "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", + "justinmimbs/date": "3.2.1", + "krisajenkins/remotedata": "6.0.1", + "ryannhg/date-format": "2.3.0" + }, + "indirect": { + "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", + "rtfeldman/elm-iso8601-date-strings": "1.1.3" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} diff --git a/users/wpcarro/assessments/tt/client/index.css b/users/wpcarro/assessments/tt/client/index.css new file mode 100644 index 000000000000..52114e0e9fb0 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/index.css @@ -0,0 +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/users/wpcarro/assessments/tt/client/index.html b/users/wpcarro/assessments/tt/client/index.html new file mode 100644 index 000000000000..9e6cef70dbb4 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/index.html @@ -0,0 +1,38 @@ +<!DOCTYPE html> +<html lang="en"> + <head> + <meta charset="UTF-8" /> + <meta name="google-signin-client_id" content="580018768696-4beppspj6cu7rhjnfgok8lbmh9a4n3ok.apps.googleusercontent.com"> + <title>Elm SPA</title> + <link rel="stylesheet" type="text/css" href="./output.css" /> + <link rel="stylesheet" type="text/css" href="./print.css" media="print" /> + <script src="https://apis.google.com/js/platform.js" async defer></script> + <script src="./Main.min.js"></script> + </head> + <body class="font-serif"> + <div id="mount"></div> + <script> + function onSignIn(googleUser) { + console.log(googleUser); + } + + var app = Elm.Main.init({node: document.getElementById("mount")}); + + app.ports.printPage.subscribe(function() { + window.print(); + }); + + app.ports.googleSignIn.subscribe(function() { + var auth2 = gapi.auth2.getAuthInstance(); + var googleUser = auth2.signIn(); + }); + + app.ports.googleSignOut.subscribe(function() { + var auth2 = gapi.auth2.getAuthInstance(); + auth2.signOut().then(function() { + console.log('Google user successfully signed out.'); + }); + }); + </script> + </body> +</html> diff --git a/users/wpcarro/assessments/tt/client/print.css b/users/wpcarro/assessments/tt/client/print.css new file mode 100644 index 000000000000..3cfb279230cb --- /dev/null +++ b/users/wpcarro/assessments/tt/client/print.css @@ -0,0 +1,3 @@ +.no-print { + display: none; +} diff --git a/users/wpcarro/assessments/tt/client/shell.nix b/users/wpcarro/assessments/tt/client/shell.nix new file mode 100644 index 000000000000..15ac040b9462 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/shell.nix @@ -0,0 +1,10 @@ +let + pkgs = import <nixpkgs> {}; +in pkgs.mkShell { + buildInputs = with pkgs; [ + nodejs + elmPackages.elm + elmPackages.elm-format + elmPackages.elm-live + ]; +} diff --git a/users/wpcarro/assessments/tt/client/src/Admin.elm b/users/wpcarro/assessments/tt/client/src/Admin.elm new file mode 100644 index 000000000000..d95609ee15e4 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Admin.elm @@ -0,0 +1,189 @@ +module Admin exposing (render) + +import Common +import Date +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Maybe.Extra as ME +import RemoteData +import State +import Tailwind +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 + RemoteData.NotAsked -> + UI.absentData { handleFetch = State.AttemptGetTrips } + + RemoteData.Loading -> + UI.paragraph "Loading..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + 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 +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.AttemptDeleteAccount x + } + ] + ] + ) + ) + + +render : State.Model -> Html State.Msg +render model = + div + [ [ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + |> class + ] + [ UI.header 2 "Welcome!" + , div [] + [ 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.Accounts -> + div [] + [ inviteUser model + , allUsers model + ] + + State.Trips -> + allTrips model + , Common.allErrors model + ] diff --git a/users/wpcarro/assessments/tt/client/src/Common.elm b/users/wpcarro/assessments/tt/client/src/Common.elm new file mode 100644 index 000000000000..63ba97b794ac --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Common.elm @@ -0,0 +1,37 @@ +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 + } + ) + ) + + +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 diff --git a/users/wpcarro/assessments/tt/client/src/Login.elm b/users/wpcarro/assessments/tt/client/src/Login.elm new file mode 100644 index 000000000000..b1a436098afd --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Login.elm @@ -0,0 +1,199 @@ +module Login exposing (render) + +import Common +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import State +import Tailwind +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 + [ [ "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 [ [ "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 + { inputId = "Username" + , pholder = "Username" + , handleInput = State.UpdateUsername + , inputValue = model.username + } + ] + , 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" } + , 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 + ] + [] + ] + , case model.loginTab of + State.LoginForm -> + div [ [ "flex", "space-around" ] |> Tailwind.use |> class ] + [ UI.simpleButton + { handleClick = State.AttemptLogin + , label = "Login" + } + , div [ [ "pl-4" ] |> Tailwind.use |> class ] [ googleSignIn ] + ] + + State.SignUpForm -> + 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" } + ] + ] + + +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 + , Common.allErrors model + ] + + +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 + } + , Common.allErrors model + ] + + +render : State.Model -> Html State.Msg +render model = + case model.session of + Nothing -> + login model + + Just x -> + logout model diff --git a/users/wpcarro/assessments/tt/client/src/Main.elm b/users/wpcarro/assessments/tt/client/src/Main.elm new file mode 100644 index 000000000000..de71a72db0df --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Main.elm @@ -0,0 +1,62 @@ +module Main exposing (main) + +import Admin +import Browser +import Html exposing (..) +import Login +import Manager +import State +import Url +import User + + +viewForRoute : State.Route -> (State.Model -> Html State.Msg) +viewForRoute route = + case route of + State.Login -> + 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.application + { init = State.init + , onUrlChange = State.UrlChanged + , onUrlRequest = State.LinkClicked + , subscriptions = \_ -> Sub.none + , update = State.update + , view = view + } diff --git a/users/wpcarro/assessments/tt/client/src/Manager.elm b/users/wpcarro/assessments/tt/client/src/Manager.elm new file mode 100644 index 000000000000..cd15c99a34a8 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Manager.elm @@ -0,0 +1,70 @@ +module Manager exposing (render) + +import Array +import Common +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.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 + (\session -> + div + [ class + ([ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + ) + ] + [ h1 [] + [ UI.header 2 ("Welcome back, " ++ session.username ++ "!") + , UI.textButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + , allUsers model + , Common.allErrors model + ] + ] + ) diff --git a/users/wpcarro/assessments/tt/client/src/Shared.elm b/users/wpcarro/assessments/tt/client/src/Shared.elm new file mode 100644 index 000000000000..addb0a4ffd12 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Shared.elm @@ -0,0 +1,7 @@ +module Shared exposing (..) + +clientOrigin = + "http://localhost:8000" + +serverOrigin = + "http://localhost:3000" diff --git a/users/wpcarro/assessments/tt/client/src/State.elm b/users/wpcarro/assessments/tt/client/src/State.elm new file mode 100644 index 000000000000..b3f78bb16980 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/State.elm @@ -0,0 +1,1014 @@ +port 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 +import Json.Encode as JE +import Json.Encode.Extra as JEE +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 + | UpdateUsername String + | UpdateEmail String + | UpdatePassword String + | UpdateRole String + | UpdateAdminTab AdminTab + | UpdateTripDestination String + | UpdateTripStartDate DatePicker.Msg + | UpdateTripEndDate DatePicker.Msg + | UpdateTripComment String + | UpdateEditTripDestination String + | UpdateEditTripComment String + | ClearErrors + | ToggleLoginForm + | PrintPage + | GoogleSignIn + | GoogleSignOut + | UpdateInviteEmail String + | UpdateInviteRole (Maybe Role) + | ReceiveTodaysDate Date.Date + | EditTrip Trip + | CancelEditTrip + -- SPA + | LinkClicked Browser.UrlRequest + | UrlChanged Url.Url + -- Outbound network + | AttemptGetAccounts + | AttemptGetTrips + | AttemptSignUp + | AttemptLogin + | AttemptLogout + | AttemptDeleteAccount String + | AttemptCreateTrip Date.Date Date.Date + | AttemptDeleteTrip Trip + | AttemptInviteUser Role + | AttemptUpdateTrip TripPK Trip + -- Inbound network + | GotAccounts (WebData (List Account)) + | GotTrips (WebData (List Trip)) + | GotSignUp (Result Http.Error Session) + | GotLogin (Result Http.Error Session) + | GotLogout (Result Http.Error String) + | GotDeleteAccount (Result Http.Error String) + | GotCreateTrip (Result Http.Error ()) + | GotDeleteTrip (Result Http.Error ()) + | GotInviteUser (Result Http.Error ()) + | GotUpdateTrip (Result Http.Error ()) + + +type Route + = Login + | UserHome + | ManagerHome + | AdminHome + + +type Role + = User + | Manager + | Admin + + +type alias Account = + { username : String + , role : Role + } + + +type alias Session = + { role : Role + , username : String + } + + +type alias Review = + { rowid : Int + , content : String + , rating : Int + , user : String + , dateOfVisit : String + } + + +type AdminTab + = Accounts + | Trips + + +type LoginTab + = LoginForm + | SignUpForm + + +type alias Trip = + { username : String + , destination : String + , startDate : Date.Date + , endDate : Date.Date + , comment : String + } + + +type alias TripPK = + { username : String + , destination : String + , startDate : Date.Date + } + + +type alias Model = + { route : Maybe Route + , url : Url.Url + , key : Nav.Key + , session : Maybe Session + , todaysDate : Maybe Date.Date + , username : String + , email : String + , password : String + , role : Maybe Role + , accounts : WebData (List Account) + , startDatePicker : DatePicker.DatePicker + , endDatePicker : DatePicker.DatePicker + , tripDestination : String + , tripStartDate : Maybe Date.Date + , 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 + , deleteUserError : Maybe Http.Error + , createTripError : Maybe Http.Error + , deleteTripError : Maybe Http.Error + , inviteUserError : 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" ) + , ( model.inviteUserError, "Error attempting to invite a user" ) + ] + + + +-------------------------------------------------------------------------------- +-- 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 + + +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 + toRole : String -> JD.Decoder Role + toRole s = + case s of + "user" -> + JD.succeed User + + "manager" -> + JD.succeed Manager + + "admin" -> + JD.succeed Admin + + x -> + JD.fail ("Invalid input: " ++ x) + 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 + , email : String + , password : String + } + -> Cmd Msg +signUp { username, email, password } = + Utils.postWithCredentials + { url = endpoint [ "accounts" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "username", JE.string username ) + , ( "email", JE.string username ) + , ( "password", JE.string password ) + , ( "role", JE.string "user" ) + ] + ) + , expect = Http.expectJson GotSignUp decodeSession + } + + +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 + { url = endpoint [ "invite" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "email", JE.string email ) + , ( "role", encodeRole role ) + ] + ) + , expect = Http.expectWhatever GotInviteUser + } + + +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 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 + } + + +deleteAccount : String -> Cmd Msg +deleteAccount username = + Utils.deleteWithCredentials + { url = endpoint [ "accounts" ] [ UrlBuilder.string "username" username ] + , body = Http.emptyBody + , expect = Http.expectString GotDeleteAccount + } + + +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) + + +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 + + +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.map5 + Trip + (JD.field "username" JD.string) + (JD.field "destination" JD.string) + (JD.field "startDate" decodeDate) + (JD.field "endDate" decodeDate) + (JD.field "comment" JD.string) + ) + ) + } + + +fetchAccounts : Cmd Msg +fetchAccounts = + Utils.getWithCredentials + { url = endpoint [ "accounts" ] [] + , expect = + Http.expectJson + (RemoteData.fromResult >> GotAccounts) + (JD.list + (JD.map2 + Account + (JD.field "username" JD.string) + (JD.field "role" decodeRole) + ) + ) + } + + +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") + ] + + +{-| Set init to `prod` when going live. +-} +prod : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +prod _ url key = + let + ( startDatePicker, startDatePickerCmd ) = + DatePicker.init + + ( endDatePicker, endDatePickerCmd ) = + DatePicker.init + in + ( { route = Nothing + , url = url + , key = key + , session = Nothing + , todaysDate = Nothing + , username = "" + , email = "" + , password = "" + , role = Nothing + , accounts = RemoteData.NotAsked + , tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + , trips = RemoteData.NotAsked + , editingTrip = Nothing + , editTripDestination = "" + , editTripComment = "" + , startDatePicker = startDatePicker + , endDatePicker = endDatePicker + , adminTab = Accounts + , loginTab = LoginForm + , inviteEmail = "" + , inviteRole = Nothing + , inviteResponseStatus = RemoteData.NotAsked + , updateTripStatus = 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 + ] + ) + + +{-| 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 + [ { username = "mimi" + , destination = "Barcelona" + , startDate = Date.fromCalendarDate 2020 Time.Sep 25 + , endDate = Date.fromCalendarDate 2020 Time.Oct 5 + , comment = "Blah" + } + , { username = "mimi" + , destination = "Paris" + , startDate = Date.fromCalendarDate 2021 Time.Jan 1 + , endDate = Date.fromCalendarDate 2021 Time.Feb 1 + , comment = "Bon voyage!" + } + ] + } + , cmd + ) + + +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 + + +port googleSignIn : () -> Cmd msg + + +port googleSignOut : () -> Cmd msg + + +{-| 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 ) +update msg model = + case msg of + DoNothing -> + ( model, Cmd.none ) + + UpdateUsername x -> + ( { model | username = x }, Cmd.none ) + + UpdatePassword x -> + ( { model | password = x }, Cmd.none ) + + UpdateEmail x -> + ( { model | email = x }, Cmd.none ) + + UpdateAdminTab x -> + ( { model | adminTab = x }, Cmd.none ) + + UpdateRole x -> + let + maybeRole = + case x of + "user" -> + Just User + + "manager" -> + Just Manager + + "admin" -> + Just Admin + + _ -> + Nothing + 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 ) + + UpdateEditTripDestination x -> + ( { model | editTripDestination = x }, Cmd.none ) + + UpdateEditTripComment x -> + ( { model | editTripComment = x }, Cmd.none ) + + ClearErrors -> + ( { model + | loginError = Nothing + , logoutError = Nothing + , signUpError = Nothing + , deleteUserError = Nothing + , createTripError = Nothing + } + , Cmd.none + ) + + ToggleLoginForm -> + ( { model + | loginTab = + case model.loginTab of + LoginForm -> + SignUpForm + + SignUpForm -> + LoginForm + } + , Cmd.none + ) + + PrintPage -> + ( model, printPage () ) + + GoogleSignIn -> + ( model, googleSignIn () ) + + GoogleSignOut -> + ( model, googleSignOut () ) + + UpdateInviteEmail x -> + ( { model | inviteEmail = x }, Cmd.none ) + + UpdateInviteRole mRole -> + ( { model | inviteRole = mRole }, Cmd.none ) + + 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 -> + ( 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 + , trips = RemoteData.Loading + } + , fetchTrips + ) + + Just ManagerHome -> + ( { model + | url = url + , route = route + , accounts = RemoteData.Loading + } + , fetchAccounts + ) + + Just AdminHome -> + ( { model + | url = url + , route = route + , accounts = RemoteData.Loading + , trips = RemoteData.Loading + } + , Cmd.batch + [ fetchAccounts + , fetchTrips + ] + ) + + _ -> + ( { model + | url = url + , route = route + } + , Cmd.none + ) + + -- GET /accounts + AttemptGetAccounts -> + ( { model | accounts = RemoteData.Loading }, fetchAccounts ) + + GotAccounts xs -> + ( { model | accounts = xs }, Cmd.none ) + + -- DELETE /accounts + AttemptDeleteAccount username -> + ( model, deleteAccount username ) + + GotDeleteAccount result -> + case result of + Ok _ -> + ( model, fetchAccounts ) + + Err e -> + ( { model | deleteUserError = Just e } + , sleepAndClearErrors + ) + + -- 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 + } + ) + + GotCreateTrip 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 + ) + + -- DELETE /trips + AttemptDeleteTrip trip -> + ( model + , deleteTrip + { username = trip.username + , destination = trip.destination + , startDate = trip.startDate + } + ) + + GotDeleteTrip result -> + case result of + Ok _ -> + ( model, fetchTrips ) + + Err e -> + ( { model | deleteTripError = Just e } + , 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 e -> + ( { model + | 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 + , signUp + { username = model.username + , email = model.email + , password = model.password + } + ) + + 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 + ) + + -- GET /trips + AttemptGetTrips -> + ( { model | trips = RemoteData.Loading }, fetchTrips ) + + GotTrips xs -> + ( { model | trips = xs }, Cmd.none ) + + -- POST /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 + ) + + -- GET /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/users/wpcarro/assessments/tt/client/src/Tailwind.elm b/users/wpcarro/assessments/tt/client/src/Tailwind.elm new file mode 100644 index 000000000000..57d419db5a82 --- /dev/null +++ b/users/wpcarro/assessments/tt/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/users/wpcarro/assessments/tt/client/src/UI.elm b/users/wpcarro/assessments/tt/client/src/UI.elm new file mode 100644 index 000000000000..7f8f379795f7 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/UI.elm @@ -0,0 +1,318 @@ +module UI exposing (..) + +import Date +import DatePicker exposing (defaultSettings) +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 "width" "800px" + , style "margin-left" "-400px" + ] + [ 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-1" + , "shadow-lg" + , "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 = [] + } + + +disabledButton : + { label : String } + -> Html State.Msg +disabledButton { label } = + baseButton + { label = label + , enabled = False + , handleClick = State.DoNothing + , extraClasses = [] + } + + +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 + , 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 + } + ] + ] + + +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 ] + + +wrapNoPrint : Html State.Msg -> Html State.Msg +wrapNoPrint component = + div [ [ "no-print" ] |> Tailwind.use |> class ] [ component ] diff --git a/users/wpcarro/assessments/tt/client/src/User.elm b/users/wpcarro/assessments/tt/client/src/User.elm new file mode 100644 index 000000000000..87871b78dbc4 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/User.elm @@ -0,0 +1,245 @@ +module User exposing (render) + +import Common +import Date +import DatePicker +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Maybe.Extra as ME +import RemoteData +import State +import Tailwind +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" + } + ] + + +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 + [ [ "py-2" ] + |> Tailwind.use + |> class + ] + [ 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 + { label = "Edit" + , handleClick = State.EditTrip trip + } + ) + , UI.wrapNoPrint + (UI.textButton + { label = "Delete" + , handleClick = State.AttemptDeleteTrip trip + } + ) + ] + + +trips : State.Model -> Html State.Msg +trips model = + div [] + [ 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" + + RemoteData.Loading -> + UI.paragraph "Loading your trips..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + 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 + (\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 + { label = "Print iternary" + , handleClick = State.PrintPage + } + ) + ] + ] + + +render : State.Model -> Html State.Msg +render model = + Common.withSession model + (\session -> + div + [ class + ([ "container" + , "mx-auto" + , "text-center" + ] + |> Tailwind.use + ) + ] + [ UI.wrapNoPrint (UI.header 2 ("Welcome, " ++ session.username ++ "!")) + , UI.wrapNoPrint (createTrip model) + , trips model + , UI.wrapNoPrint + (UI.textButton + { label = "Logout" + , handleClick = State.AttemptLogout + } + ) + , Common.allErrors model + ] + ) diff --git a/users/wpcarro/assessments/tt/client/src/Utils.elm b/users/wpcarro/assessments/tt/client/src/Utils.elm new file mode 100644 index 000000000000..60343cd87018 --- /dev/null +++ b/users/wpcarro/assessments/tt/client/src/Utils.elm @@ -0,0 +1,109 @@ +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 + , body : Http.Body + , expect : Http.Expect msg + } + -> Cmd msg +deleteWithCredentials { url, body, expect } = + Http.riskyRequest + { url = url + , headers = [ Http.header "Origin" Shared.clientOrigin ] + , method = "DELETE" + , timeout = Nothing + , tracker = Nothing + , body = body + , 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 = + DateFormat.format + [ DateFormat.monthNameFull + , DateFormat.text " " + , DateFormat.dayOfMonthSuffix + , DateFormat.text ", " + , DateFormat.yearNumber + ] + Time.utc + ts diff --git a/users/wpcarro/assessments/tt/data/accounts.csv b/users/wpcarro/assessments/tt/data/accounts.csv new file mode 100644 index 000000000000..f5fc77b6d77f --- /dev/null +++ b/users/wpcarro/assessments/tt/data/accounts.csv @@ -0,0 +1,2 @@ +mimi,$2b$12$LynoGCNbe2RA1WWSiBEMVudJKs5dxnssY16rYmUyiwlSBIhHBOLbu,miriamwright@google.com,user, +wpcarro,$2b$12$3wbi4xfQmksLsu6GOKTbj.5WHywESATnXB4R8FJ55RSRLy6X9xA7u,wpcarro@google.com,admin, \ No newline at end of file diff --git a/users/wpcarro/assessments/tt/data/trips.csv b/users/wpcarro/assessments/tt/data/trips.csv new file mode 100644 index 000000000000..a583c750f77c --- /dev/null +++ b/users/wpcarro/assessments/tt/data/trips.csv @@ -0,0 +1,3 @@ +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 diff --git a/users/wpcarro/assessments/tt/populate.sqlite3 b/users/wpcarro/assessments/tt/populate.sqlite3 new file mode 100644 index 000000000000..e200d2b49c02 --- /dev/null +++ b/users/wpcarro/assessments/tt/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 diff --git a/users/wpcarro/assessments/tt/shell.nix b/users/wpcarro/assessments/tt/shell.nix new file mode 100644 index 000000000000..567b71060b7b --- /dev/null +++ b/users/wpcarro/assessments/tt/shell.nix @@ -0,0 +1,23 @@ +let + pkgs = import <nixpkgs> {}; + 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; [ + hpkgs.servant-server + hpkgs.aeson + hpkgs.resource-pool + hpkgs.sqlite-simple + hpkgs.wai-cors + hpkgs.warp + hpkgs.cryptonite + hpkgs.uuid + hpkgs.envy + hailgun + ])) + ]; +} diff --git a/users/wpcarro/assessments/tt/src/.ghci b/users/wpcarro/assessments/tt/src/.ghci new file mode 100644 index 000000000000..efc88e630ccb --- /dev/null +++ b/users/wpcarro/assessments/tt/src/.ghci @@ -0,0 +1,2 @@ +:set prompt "> " +:set -Wall diff --git a/users/wpcarro/assessments/tt/src/API.hs b/users/wpcarro/assessments/tt/src/API.hs new file mode 100644 index 000000000000..471fa761e0f4 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/API.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +-------------------------------------------------------------------------------- +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] "Cookie" T.SessionCookie + +type API = + -- accounts: Create + "accounts" + :> Header "Cookie" T.SessionCookie + :> ReqBody '[JSON] T.CreateAccountRequest + :> Post '[JSON] NoContent + :<|> "verify" + :> ReqBody '[JSON] T.VerifyAccountRequest + :> Post '[JSON] NoContent + -- accounts: Read + -- 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" + :> SessionCookie + :> ReqBody '[JSON] T.UpdateTripRequest + :> Put '[JSON] NoContent + -- trips: Delete + :<|> "trips" + :> SessionCookie + :> ReqBody '[JSON] T.TripPK + :> Delete '[JSON] NoContent + -- trips: List + :<|> "trips" + :> SessionCookie + :> Get '[JSON] [T.Trip] + + -- Miscellaneous + :<|> "login" + :> ReqBody '[JSON] T.AccountCredentials + :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] T.Session) + :<|> "logout" + :> SessionCookie + :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) + :<|> "unfreeze" + :> SessionCookie + :> ReqBody '[JSON] T.UnfreezeAccountRequest + :> Post '[JSON] NoContent + :<|> "invite" + :> SessionCookie + :> ReqBody '[JSON] T.InviteUserRequest + :> Post '[JSON] NoContent + :<|> "accept-invitation" + :> ReqBody '[JSON] T.AcceptInvitationRequest + :> Post '[JSON] NoContent diff --git a/users/wpcarro/assessments/tt/src/Accounts.hs b/users/wpcarro/assessments/tt/src/Accounts.hs new file mode 100644 index 000000000000..c7ab7a2f135f --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Accounts.hs @@ -0,0 +1,49 @@ +{-# 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 + 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 username,password,email,role,profilePicture 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 username,password,email,role,profilePicture FROM Accounts" + pure $ T.userFromAccount <$> accounts diff --git a/users/wpcarro/assessments/tt/src/App.hs b/users/wpcarro/assessments/tt/src/App.hs new file mode 100644 index 000000000000..742bc962dc55 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/App.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Servant +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 Data.UUID 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 Invitations as Invitations +import qualified LoginAttempts as LoginAttempts +import qualified PendingAccounts as PendingAccounts +-------------------------------------------------------------------------------- + +err429 :: ServerError +err429 = ServerError + { errHTTPCode = 429 + , errReasonPhrase = "Too many requests" + , errBody = "" + , errHeaders = [] + } + +-- | Send an email to recipient, `to`, with a secret code. +sendVerifyEmail :: T.Config + -> T.Username + -> T.Email + -> T.RegistrationSecret + -> IO (Either Email.SendError Email.SendSuccess) +sendVerifyEmail T.Config{..} (T.Username username) email (T.RegistrationSecret secretUUID) = do + Email.send mailgunAPIKey subject (cs body) email + where + subject = "Please confirm your account" + body = + let secret = secretUUID |> UUID.toString in + "To verify your account: POST /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 + "To accept the invitation: POST /accept-invitation username=<username> password=<password> email=" ++ cs to ++ " secret=" ++ secret + +server :: T.Config -> Server API +server config@T.Config{..} = createAccount + :<|> verifyAccount + :<|> deleteAccount + :<|> listAccounts + :<|> createTrip + :<|> updateTrip + :<|> deleteTrip + :<|> listTrips + :<|> login + :<|> 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) + -- Admit Admins only. + adminsOnly cookie = adminsAnd cookie (const True) + + -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s + 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, _) -> + adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) doCreateAccount + where + doCreateAccount :: Handler NoContent + doCreateAccount = do + secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO + liftIO $ PendingAccounts.create dbFile + secretUUID + createAccountRequestUsername + createAccountRequestPassword + createAccountRequestRole + createAccountRequestEmail + res <- liftIO $ sendVerifyEmail config + createAccountRequestUsername + createAccountRequestEmail + secretUUID + case res of + Left _ -> undefined + Right _ -> pure NoContent + + verifyAccount :: T.VerifyAccountRequest -> Handler NoContent + verifyAccount T.VerifyAccountRequest{..} = do + mPendingAccount <- liftIO $ PendingAccounts.get dbFile verifyAccountRequestUsername + case mPendingAccount of + Nothing -> + throwError err401 { errBody = "Either your secret or your username (or both) is invalid" } + Just pendingAccount@T.PendingAccount{..} -> + if pendingAccountSecret == verifyAccountRequestSecret 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) + pure NoContent + + 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 + + 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 + liftIO $ Trips.delete dbFile tripPK + pure NoContent + + 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] T.Session) + login (T.AccountCredentials username password) = do + mAccount <- liftIO $ Accounts.lookup dbFile username + case mAccount of + Just account@T.Account{..} -> do + mAttempts <- liftIO $ LoginAttempts.forUsername dbFile accountUsername + case mAttempts of + Nothing -> + if T.passwordsMatch password accountPassword then do + uuid <- liftIO $ Sessions.findOrCreate dbFile account + 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" } + Just attempts -> + if attempts >= 3 then + throwError err429 + else if T.passwordsMatch password accountPassword then do + uuid <- liftIO $ Sessions.findOrCreate dbFile account + 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" } + + -- In this branch, the user didn't supply a known username. + Nothing -> throwError err401 { errBody = "Your credentials are invalid" } + + logout :: T.SessionCookie + -> 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 + + 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 + + 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 + res <- liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID + case res of + Left _ -> undefined + Right _ -> 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) + 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"] + } diff --git a/users/wpcarro/assessments/tt/src/Auth.hs b/users/wpcarro/assessments/tt/src/Auth.hs new file mode 100644 index 000000000000..f1bff23257e0 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Auth.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Auth where +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Web.Cookie +import Servant + +import qualified Data.UUID as UUID +import qualified Sessions as Sessions +import qualified Accounts as Accounts +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | 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 account associated with `cookie`. +accountFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Account) +accountFromCookie dbFile cookie = + 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 x -> pure (Just x) + +-- | 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 = "" + } + +-- | 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" } diff --git a/users/wpcarro/assessments/tt/src/Email.hs b/users/wpcarro/assessments/tt/src/Email.hs new file mode 100644 index 000000000000..2dac0973ba6d --- /dev/null +++ b/users/wpcarro/assessments/tt/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 y -> pure $ Right (SendSuccess y) + 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 = [] + }) + [] diff --git a/users/wpcarro/assessments/tt/src/Invitations.hs b/users/wpcarro/assessments/tt/src/Invitations.hs new file mode 100644 index 000000000000..0c700470f3e2 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Invitations.hs @@ -0,0 +1,21 @@ +{-# 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) + +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/users/wpcarro/assessments/tt/src/LoginAttempts.hs b/users/wpcarro/assessments/tt/src/LoginAttempts.hs new file mode 100644 index 000000000000..d78e12e3fd8a --- /dev/null +++ b/users/wpcarro/assessments/tt/src/LoginAttempts.hs @@ -0,0 +1,30 @@ +{-# 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 username,numAttempts FROM LoginAttempts WHERE username = ?" + (Only username) + case res of + [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 "INSERT INTO LoginAttempts (username,numAttempts) VALUES (?,?) ON CONFLICT (username) DO UPDATE SET numAttempts = numAttempts + 1" + (username, 1 :: Integer) diff --git a/users/wpcarro/assessments/tt/src/Main.hs b/users/wpcarro/assessments/tt/src/Main.hs new file mode 100644 index 000000000000..9df4232066bb --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Main.hs @@ -0,0 +1,13 @@ +-------------------------------------------------------------------------------- +module Main where +-------------------------------------------------------------------------------- +import qualified App +import qualified System.Envy as Envy +-------------------------------------------------------------------------------- + +main :: IO () +main = do + mEnv <- Envy.decodeEnv + case mEnv of + Left err -> putStrLn err + Right env -> App.run env diff --git a/users/wpcarro/assessments/tt/src/PendingAccounts.hs b/users/wpcarro/assessments/tt/src/PendingAccounts.hs new file mode 100644 index 000000000000..a555185fa717 --- /dev/null +++ b/users/wpcarro/assessments/tt/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 secret,username,password,role,email 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/users/wpcarro/assessments/tt/src/Sessions.hs b/users/wpcarro/assessments/tt/src/Sessions.hs new file mode 100644 index 000000000000..713059a38383 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Sessions.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +module Sessions where +-------------------------------------------------------------------------------- +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 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) + 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 + res <- query conn "SELECT uuid,username,tsCreated 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.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. +findOrCreate :: FilePath -> T.Account -> IO T.SessionUUID +findOrCreate dbFile account = + 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 uuid,username,tsCreated FROM Sessions" diff --git a/users/wpcarro/assessments/tt/src/Trips.hs b/users/wpcarro/assessments/tt/src/Trips.hs new file mode 100644 index 000000000000..f90740363c52 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Trips.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Trips where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple +import Utils + +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) + +-- | 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 tripKey = + withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" + (T.tripPKFields 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 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 = ? ORDER BY date(startDate) ASC" + (Only username) diff --git a/users/wpcarro/assessments/tt/src/Types.hs b/users/wpcarro/assessments/tt/src/Types.hs new file mode 100644 index 000000000000..6b06a39694fc --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Types.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +-------------------------------------------------------------------------------- +module Types where +-------------------------------------------------------------------------------- +import Data.Aeson +import Utils +import Data.Text +import Data.Typeable +import Database.SQLite.Simple +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 System.Envy (FromEnv, fromEnv, env) +import Crypto.Random.Types (MonadRandom) + +import qualified Data.Time.Calendar as Calendar +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.Maybe as M +import qualified Data.UUID as UUID +-------------------------------------------------------------------------------- + +-- | Top-level application configuration. +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. +forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b +forNewtype wrapper y = + case fieldData y of + (SQLText x) -> Ok (wrapper x) + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) + +newtype Username = Username Text + deriving (Eq, Show, Generic) + +instance ToJSON Username +instance FromJSON Username + +instance ToField Username where + toField (Username x) = SQLText x + +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 y = + case fieldData y of + (SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) + +newtype ClearTextPassword = ClearTextPassword Text + deriving (Eq, Show, Generic) + +instance ToJSON ClearTextPassword +instance FromJSON ClearTextPassword + +instance ToField ClearTextPassword where + toField (ClearTextPassword x) = SQLText x + +instance FromField ClearTextPassword where + fromField = forNewtype ClearTextPassword + +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, Generic) + +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 + _ -> fail "Expected \"user\" or \"manager\" or \"admin\"" + +instance ToField Role where + toField RegularUser = SQLText "user" + toField Manager = SQLText "manager" + toField Admin = SQLText "admin" + +instance FromField Role where + fromField y = + case fieldData y of + (SQLText "user") -> Ok RegularUser + (SQLText "manager") -> Ok Manager + (SQLText "admin") -> Ok Admin + 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 + 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 :: HashedPassword + , accountEmail :: Email + , accountRole :: Role + , accountProfilePicture :: Maybe ProfilePicture + } deriving (Eq, Show, Generic) + +-- | 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 + ) + +instance FromRow Account where + fromRow = do + accountUsername <- field + accountPassword <- field + accountEmail <- field + accountRole <- field + accountProfilePicture <- field + pure Account{..} + +data Session = Session + { sessionUsername :: Username + , sessionRole :: Role + } deriving (Eq, Show) + +instance ToJSON Session where + toJSON (Session username role) = + object [ "username" .= username + , "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 + +newtype Destination = Destination Text + deriving (Eq, Show, Generic) + +instance ToJSON Destination +instance FromJSON Destination + +instance ToField Destination where + toField (Destination x) = SQLText x + +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 :: Calendar.Day + , tripEndDate :: Calendar.Day + , tripComment :: Comment + } deriving (Eq, Show, Generic) + +instance FromRow Trip where + 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 + { tripPKUsername :: Username + , tripPKDestination :: Destination + , tripPKStartDate :: Calendar.Day + } deriving (Eq, Show, Generic) + +tripPKFields :: TripPK -> (Username, Destination, Calendar.Day) +tripPKFields (TripPK{..}) + = (tripPKUsername, tripPKDestination, tripPKStartDate) + +instance FromJSON TripPK where + parseJSON = withObject "TripPK" $ \x -> do + 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, Calendar.Day, Calendar.Day, Comment) +tripFields (Trip{..}) + = ( tripUsername + , tripDestination + , tripStartDate + , tripEndDate + , tripComment + ) + +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 + 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 +-- passwords and emails. +data User = User + { userUsername :: Username + , userProfilePicture :: Maybe ProfilePicture + , userRole :: Role + } deriving (Eq, Show, Generic) + +instance ToJSON User where + toJSON (User username profilePicture role) = + object [ "username" .= username + , "profilePicture" .= profilePicture + , "role" .= role + ] + +userFromAccount :: Account -> User +userFromAccount account = + User { userUsername = accountUsername 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 + accountCredentialsUsername <- x.: "username" + accountCredentialsPassword <- x.: "password" + pure AccountCredentials{..} + + +-- | Hash password `x`. +hashPassword :: (MonadRandom m) => ClearTextPassword -> m HashedPassword +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 + , createAccountRequestEmail :: Email + , createAccountRequestRole :: Role + } deriving (Eq, Show) + +instance FromJSON CreateAccountRequest where + parseJSON = withObject "CreateAccountRequest" $ \x -> do + createAccountRequestUsername <- x .: "username" + createAccountRequestPassword <- x .: "password" + createAccountRequestEmail <- x .: "email" + createAccountRequestRole <- x .: "role" + pure $ CreateAccountRequest{..} + +createAccountRequestFields :: CreateAccountRequest + -> (Username, ClearTextPassword, Email, Role) +createAccountRequestFields CreateAccountRequest{..} = + ( createAccountRequestUsername + , createAccountRequestPassword + , createAccountRequestEmail + , createAccountRequestRole + ) + +newtype SessionUUID = SessionUUID UUID.UUID + deriving (Eq, Show, Generic) + +instance FromField SessionUUID where + fromField y = + case fieldData y of + (SQLText x) -> + case UUID.fromText x of + 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) = + uuid |> UUID.toText |> SQLText + +data StoredSession = StoredSession + { storedSessionUUID :: SessionUUID + , storedSessionUsername :: Username + , storedSessionTsCreated :: Clock.UTCTime + } deriving (Eq, Show, Generic) + +instance FromRow StoredSession where + fromRow = do + storedSessionUUID <- field + storedSessionUsername <- field + storedSessionTsCreated <- field + pure StoredSession {..} + +data LoginAttempt = LoginAttempt + { loginAttemptUsername :: Username + , loginAttemptNumAttempts :: Integer + } deriving (Eq, Show) + +instance FromRow LoginAttempt where + fromRow = do + loginAttemptUsername <- field + loginAttemptNumAttempts <- field + pure LoginAttempt {..} + +newtype SessionCookie = SessionCookie Cookies + +instance FromHttpApiData SessionCookie where + parseHeader x = + x |> parseCookies |> SessionCookie |> pure + parseQueryParam x = + x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure + +newtype RegistrationSecret = RegistrationSecret UUID.UUID + 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 y = + case fieldData y of + (SQLText x) -> + case UUID.fromText x of + 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) = + secretUUID |> UUID.toText |> SQLText + +instance FromJSON RegistrationSecret + +data VerifyAccountRequest = VerifyAccountRequest + { verifyAccountRequestUsername :: Username + , verifyAccountRequestSecret :: RegistrationSecret + } deriving (Eq, Show) + +instance FromJSON VerifyAccountRequest where + parseJSON = withObject "VerifyAccountRequest" $ \x -> do + verifyAccountRequestUsername <- x .: "username" + verifyAccountRequestSecret <- x .: "secret" + pure VerifyAccountRequest{..} + +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 {..} + +data UpdateTripRequest = UpdateTripRequest + { updateTripRequestTripPK :: TripPK + , updateTripRequestDestination :: Maybe Destination + , updateTripRequestStartDate :: Maybe Calendar.Day + , updateTripRequestEndDate :: Maybe Calendar.Day + , 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 + } + +data UnfreezeAccountRequest = UnfreezeAccountRequest + { unfreezeAccountRequestUsername :: Username + } deriving (Eq, Show) + +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, Generic) + +instance ToJSON InvitationSecret +instance FromJSON InvitationSecret + +instance ToField InvitationSecret where + toField (InvitationSecret secretUUID) = + secretUUID |> UUID.toText |> SQLText + +instance FromField InvitationSecret where + fromField y = + case fieldData y of + (SQLText x) -> + case UUID.fromText x of + 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 + , 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{..} diff --git a/users/wpcarro/assessments/tt/src/Utils.hs b/users/wpcarro/assessments/tt/src/Utils.hs new file mode 100644 index 000000000000..48c33af0796d --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Utils.hs @@ -0,0 +1,9 @@ +-------------------------------------------------------------------------------- +module Utils where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +-------------------------------------------------------------------------------- + +-- | Prefer this operator to the ampersand for stylistic reasons. +(|>) :: a -> (a -> b) -> b +(|>) = (&) diff --git a/users/wpcarro/assessments/tt/src/init.sql b/users/wpcarro/assessments/tt/src/init.sql new file mode 100644 index 000000000000..b42753ae5d01 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/init.sql @@ -0,0 +1,67 @@ +-- 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; +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, + 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 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 +); + +CREATE TABLE Sessions ( + uuid TEXT CHECK(LENGTH(uuid) == 36) NOT NULL, + username TEXT NOT NULL UNIQUE, + -- 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 +); + +CREATE TABLE LoginAttempts ( + username TEXT NOT NULL UNIQUE, + numAttempts INTEGER NOT NULL, + PRIMARY KEY (username), + 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) +); + +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; diff --git a/users/wpcarro/assessments/tt/tests/create-accounts.sh b/users/wpcarro/assessments/tt/tests/create-accounts.sh new file mode 100755 index 000000000000..8c2a66bc8bd7 --- /dev/null +++ b/users/wpcarro/assessments/tt/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 diff --git a/users/wpcarro/assessments/tt/todo.org b/users/wpcarro/assessments/tt/todo.org new file mode 100644 index 000000000000..39592d04826b --- /dev/null +++ b/users/wpcarro/assessments/tt/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 |