Add 'assessments/tt/' from commit 'ee8e75231cd9d3d4aa3ffbbfa0e3b8511712e1ee'

git-subtree-dir: assessments/tt
git-subtree-mainline: 67e0f93b3b
git-subtree-split: ee8e75231c
This commit is contained in:
William Carroll 2021-01-22 10:49:52 +00:00
commit e326b0da45
42 changed files with 3994 additions and 0 deletions

6
assessments/tt/.gitignore vendored Normal file
View file

@ -0,0 +1,6 @@
.envrc
*.db
*.sqlite3
!populate.sqlite3
*.db-shm
*.db-wal

50
assessments/tt/README.md Normal file
View file

@ -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;
```

3
assessments/tt/client/.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
/elm-stuff
/Main.min.js
/output.css

View file

@ -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`!

View file

@ -0,0 +1,3 @@
let
briefcase = import /home/wpcarro/briefcase {};
in briefcase.utils.nixBufferFromShell ./shell.nix

View file

@ -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": {}
}
}

View file

@ -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;
}

View file

@ -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>

View file

@ -0,0 +1,3 @@
.no-print {
display: none;
}

View file

@ -0,0 +1,10 @@
let
pkgs = import <nixpkgs> {};
in pkgs.mkShell {
buildInputs = with pkgs; [
nodejs
elmPackages.elm
elmPackages.elm-format
elmPackages.elm-live
];
}

View file

@ -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
]

View file

@ -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

View file

@ -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

View file

@ -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
}

View file

@ -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
]
]
)

View file

@ -0,0 +1,7 @@
module Shared exposing (..)
clientOrigin =
"http://localhost:8000"
serverOrigin =
"http://localhost:3000"

File diff suppressed because it is too large Load diff

View file

@ -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

View file

@ -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 ]

View file

@ -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
]
)

View file

@ -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

View file

@ -0,0 +1,2 @@
mimi,$2b$12$LynoGCNbe2RA1WWSiBEMVudJKs5dxnssY16rYmUyiwlSBIhHBOLbu,miriamwright@google.com,user,
wpcarro,$2b$12$3wbi4xfQmksLsu6GOKTbj.5WHywESATnXB4R8FJ55RSRLy6X9xA7u,wpcarro@google.com,admin,
1 mimi $2b$12$LynoGCNbe2RA1WWSiBEMVudJKs5dxnssY16rYmUyiwlSBIhHBOLbu miriamwright@google.com user
2 wpcarro $2b$12$3wbi4xfQmksLsu6GOKTbj.5WHywESATnXB4R8FJ55RSRLy6X9xA7u wpcarro@google.com admin

View file

@ -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...
1 mimi Rome 2020-08-10 2020-08-12 Heading home before the upcoming trip with Panarea.
2 mimi Panarea 2020-08-15 2020-08-28 Exciting upcoming trip with Matt and Sarah!
3 mimi London 2020-08-30 2020-09-15 Heading back to London...

View file

@ -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

23
assessments/tt/shell.nix Normal file
View file

@ -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
]))
];
}

2
assessments/tt/src/.ghci Normal file
View file

@ -0,0 +1,2 @@
:set prompt "> "
:set -Wall

76
assessments/tt/src/API.hs Normal file
View file

@ -0,0 +1,76 @@
{-# 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"
:> QueryParam' '[Required] "username" Text
:> QueryParam' '[Required] "secret" T.RegistrationSecret
:> Get '[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

View file

@ -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

272
assessments/tt/src/App.hs Normal file
View file

@ -0,0 +1,272 @@
{-# 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"
-- TODO(wpcarro): Use a URL encoder
-- TODO(wpcarro): Use a dynamic domain and port number
body =
let secret = secretUUID |> UUID.toString in
cs configServer ++ "/verify?username=" ++ cs username ++ "&secret=" ++ secret
-- | Send an invitation email to recipient, `to`, with a secret code.
sendInviteEmail :: T.Config
-> T.Email
-> T.InvitationSecret
-> IO (Either Email.SendError Email.SendSuccess)
sendInviteEmail T.Config{..} email@(T.Email to) (T.InvitationSecret secretUUID) = do
Email.send mailgunAPIKey subject (cs body) email
where
subject = "You've been invited!"
body =
let secret = secretUUID |> UUID.toString in
"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 :: Text -> T.RegistrationSecret -> Handler NoContent
verifyAccount username secretUUID = do
mPendingAccount <- liftIO $ PendingAccounts.get dbFile (T.Username username)
case mPendingAccount of
Nothing ->
throwError err401 { errBody = "Either your secret or your username (or both) is invalid" }
Just pendingAccount@T.PendingAccount{..} ->
if pendingAccountSecret == secretUUID then do
liftIO $ Accounts.transferFromPending dbFile pendingAccount
pure NoContent
else
throwError err401 { errBody = "The secret you provided is invalid" }
deleteAccount :: T.SessionCookie -> Text -> Handler NoContent
deleteAccount cookie username = adminsOnly cookie $ do
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"]
}

View file

@ -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" }

View file

@ -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 = []
})
[]

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -0,0 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module PendingAccounts where
--------------------------------------------------------------------------------
import Database.SQLite.Simple
import qualified Types as T
--------------------------------------------------------------------------------
create :: FilePath
-> T.RegistrationSecret
-> T.Username
-> T.ClearTextPassword
-> T.Role
-> T.Email
-> IO ()
create dbFile secret username password role email = withConnection dbFile $ \conn -> do
hashed <- T.hashPassword password
execute conn "INSERT INTO PendingAccounts (secret,username,password,role,email) VALUES (?,?,?,?,?)"
(secret, username, hashed, role, email)
get :: FilePath -> T.Username -> IO (Maybe T.PendingAccount)
get dbFile username = withConnection dbFile $ \conn -> do
res <- query conn "SELECT 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)

View file

@ -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"

View file

@ -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)

531
assessments/tt/src/Types.hs Normal file
View file

@ -0,0 +1,531 @@
{-# 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
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{..}

View file

@ -0,0 +1,9 @@
--------------------------------------------------------------------------------
module Utils where
--------------------------------------------------------------------------------
import Data.Function ((&))
--------------------------------------------------------------------------------
-- | Prefer this operator to the ampersand for stylistic reasons.
(|>) :: a -> (a -> b) -> b
(|>) = (&)

View file

@ -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;

View file

@ -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

18
assessments/tt/todo.org Normal file
View file

@ -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