subtree(users/wpcarro): docking briefcase at '24f5a642'

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c
git-subtree-split: 24f5a642af
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789
This commit is contained in:
Vincent Ambo 2021-12-14 01:51:19 +03:00
commit 019f8fd211
766 changed files with 175420 additions and 0 deletions

8
users/wpcarro/.envrc Normal file
View file

@ -0,0 +1,8 @@
export BRIEFCASE="$(realpath .)"
# I'm ensuring that $NIX_PATH is mostly empty, so that I only depend on
# <briefcase> for now.
# For more information on the NIX_PATH anti-pattern, see here:
# https://nix.dev/tutorials/towards-reproducibility-pinning-nixpkgs.html#pinning-nixpkgs
export NIX_PATH="briefcase=$BRIEFCASE";
export DESKTOP="zeno.lon.corp.google.com";
export LAPTOP="seneca";

31
users/wpcarro/.gitignore vendored Normal file
View file

@ -0,0 +1,31 @@
.vim
./configs/secrets
**/*/.emacs.d/quelpa/**/*
**/*/.emacs.d/elpa/**/*
**/*/.emacs.d/emojis
**/*/.emacs.d/auto-save-list/**/*
**/*/.emacs.d/eshell/
**/*/.emacs.d/var/**/*
**/*/.emacs.d/.cache/**/*
**/*/.emacs.d/request
**/*/.emacs.d/network-security.data
**/*/.emacs.d/smex-items
**/*/.gnupg/random_seed
.netrwhist
Vundle.vim
**/*/.emacs.d/custom.el
**/*/.emacs.d/projectile-bookmarks.eld
**/*/.emacs.d/bookmarks
**/*/transient/history.el
*.hi
*.o
__pycache__
*.class
node_modules/
/configs/.config/fish/config.fish
/configs/.config/fish/fish_variables
/website/blog/public/
/emacs/.emacs.d/tramp
.gitsecret/keys/random_seed
!*.secret
secrets.json

Binary file not shown.

Binary file not shown.

Binary file not shown.

View file

@ -0,0 +1 @@
secrets.json:7d596a3ed16403040d89dd7e033a2af58e7aaabb6f246f44751b80a1863a2949

View file

@ -0,0 +1,2 @@
Do not recurse from top-level readTree, while this is being refactored
we have a nested tree.

9
users/wpcarro/Makefile Normal file
View file

@ -0,0 +1,9 @@
install:
source "${BRIEFCASE}/configs/install"
uninstall:
source "${BRIEFCASE}/configs/uninstall"
list-broken-links:
find "${HOME}" -maxdepth 1 -xtype l && \
find "${HOME}/.config" -maxdepth 1 -xtype l

70
users/wpcarro/README.md Normal file
View file

@ -0,0 +1,70 @@
# briefcase
[![Build status](https://badge.buildkite.com/aa0d413bfeedcafd8719f977eadd40e04d0b5334fc7f58e8ee.svg)](https://buildkite.com/wpcarros-infrastructure/post-receive)
Welcome to my monorepo: briefcase.
Herein you will find a variety of libraries, packages, and documents. Some of
this work in finished and other work is incomplete or just a sketch for a
future project.
Where applicable, I try to include `README.md` files in some of the
subdirectories to help orient both myself and any onlookers.
## Languages
To give you a general idea of the source code inside of this monorepo, here is
the latest output from `tokei --hidden --sort code .`:
```text
-------------------------------------------------------------------------------
Language Files Lines Code Comments Blanks
-------------------------------------------------------------------------------
Emacs Lisp 81 22267 13847 5661 2759
Python 177 10575 7930 885 1760
Elm 34 5345 4277 219 849
Haskell 50 4263 3111 428 724
Nix 66 1581 1379 66 136
TypeScript 19 1345 1067 90 188
Go 17 1256 926 173 157
Vim Script 2 766 470 87 209
Elixir 13 358 301 8 49
JavaScript 9 77 73 0 4
Lisp 3 83 43 23 17
Shell 3 55 30 11 14
Clojure 2 10 8 0 2
C 1 6 5 0 1
Rust 1 5 3 1 1
-------------------------------------------------------------------------------
Total 478 47992 33470 7652 6870
-------------------------------------------------------------------------------
```
## Sign posts
Below I have outlined a few projects that you might find interesting. I am
using `//` to indicate the root of my monorepo, the directory in which this
`README.md` resides.
- `//boilerplate`: scaffolding for projects. Boilerplate's goal is to
reduce the startup costs of a project.
- `//configs`: my dotfiles (e.g. `config.fish`, `init.vim`).
- `//emacs`: Emacs is both my preferred text editor and my window manager; with
tens of thousands of lines of Emacs Lisp, you can safely assume that this
directory hosts a lot of libraries and packages.
- `//monzo_ynab`: `systemd` timer unit that imports my Monzo (i.e. a U.K.-based
online bank) transactions into the personal finance tool YNAB (i.e.
youneedabudget.com).
- `//nixos`: my declarative configuration for my NixOS machines. If you are
unfamiliar with Nix, I recommend reading about the NixOS project.
- `//tools`: some scripts and projects that simplify my life.
- `//website`: everything required to build my website, wpcarro.dev.
## Notes to self
Here are a few reminders when setting up a new machine:
- Ensure `~/.password-store` exists.
- Run `export_gpg` from a computer with my gpg credentials. Run `import_gpg`
from the new machine.
- Ensure the new machine can access my Github.

View file

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

View file

@ -0,0 +1,41 @@
--------------------------------------------------------------------------------
module App where
--------------------------------------------------------------------------------
import Keyboard (Keyboard(..))
import Transforms (Transform(..))
import Utils ((|>))
import qualified Data.Char as Char
import qualified Utils
import qualified Data.List.Split as Split
import qualified Keyboard
import qualified Data.HashMap.Strict as HM
--------------------------------------------------------------------------------
transform :: Keyboard -> Transform -> Keyboard
transform (Keyboard xs) xform =
case xform of
HorizontalFlip ->
xs
|> fmap reverse
|> Keyboard
VerticalFlip ->
xs
|> reverse
|> Keyboard
Shift n ->
xs
|> concat
|> Utils.rotate n
|> Split.chunksOf 10
|> Keyboard
retypePassage :: String -> Keyboard -> Maybe String
retypePassage passage newKeyboard =
passage
|> fmap Char.toUpper
|> traverse (\c -> HM.lookup c Keyboard.charToCoord)
>>= traverse (Keyboard.coordToChar newKeyboard)

View file

@ -0,0 +1,58 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
--------------------------------------------------------------------------------
module Keyboard where
--------------------------------------------------------------------------------
import Utils
import Data.Coerce
import Data.Hashable (Hashable)
import GHC.Generics (Generic)
import qualified Data.List as List
import qualified Data.HashMap.Strict as HM
--------------------------------------------------------------------------------
newtype Keyboard = Keyboard [[Char]]
deriving (Eq)
instance Show Keyboard where
show (Keyboard xxs) =
xxs |> fmap printRow |> List.intercalate "\n"
where
printRow :: [Char] -> String
printRow xs =
xs |> fmap (\x -> '[':x:']':"") |> List.intercalate ""
data Coord = Coord
{ row :: Int
, col :: Int
} deriving (Eq, Show, Generic)
instance Hashable Coord
-- | List of characters to their QWERTY coordinatees.
coords :: [(Char, Coord)]
coords =
qwerty
|> coerce
|> fmap (zip [0..])
|> zip [0..]
|> fmap (\(row, xs) -> xs |> fmap (\(col, char) -> (char, Coord row col)))
|> mconcat
-- | Mapping of characters to their coordinates on a QWERTY keyboard with the
-- top-left corner as 0,0.
charToCoord :: HM.HashMap Char Coord
charToCoord = HM.fromList coords
coordToChar :: Keyboard -> Coord -> Maybe Char
coordToChar (Keyboard xxs) Coord{..} =
Just $ xxs !! row !! col
qwerty :: Keyboard
qwerty = Keyboard [ ['1','2','3','4','5','6','7','8','9','0']
, ['Q','W','E','R','T','Y','U','I','O','P']
, ['A','S','D','F','G','H','J','K','L',';']
, ['Z','X','C','V','B','N','M',',','.','/']
]

View file

@ -0,0 +1,43 @@
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Main where
--------------------------------------------------------------------------------
import Options.Applicative
import Data.Semigroup ((<>))
import qualified Transforms
import qualified Keyboard
import qualified App
--------------------------------------------------------------------------------
data CommandArgs = CommandArgs
{ transforms :: String
, passage :: String
} deriving (Eq, Show)
parseArgs :: Parser CommandArgs
parseArgs =
CommandArgs <$> strOption
( long "transforms"
<> short 't'
<> help "String of transforms where (e.g. \"HHVS12VHVHS3\")" )
<*> strOption
( long "passage"
<> short 'p'
<> help "Input text to re-type" )
main :: IO ()
main = do
CommandArgs{..} <- execParser opts
case Transforms.fromString transforms of
Nothing -> putStrLn "You must provide valid input (e.g. \"HHVS12VHVHS3\")"
Just xs -> do
let keyboard = foldl App.transform Keyboard.qwerty (Transforms.optimize xs)
putStrLn $ "Typing: \"" ++ passage ++ "\"\nOn this keyboard:\n" ++ show keyboard
case App.retypePassage passage keyboard of
Nothing -> putStrLn $ "Looks like at least one of the characters in your input passage doesn't fit on our QWERTY keyboard: \n" ++ show Keyboard.qwerty
Just result -> putStrLn $ "Result: " ++ result
where
opts = info (parseArgs <**> helper)
( fullDesc
<> progDesc "Transform a QWERTY keyboard using a string of commands")

View file

@ -0,0 +1,82 @@
# Transform QWERTY
Apply a series of transforms to a QWERTY keyboard then use the new keyboard to
re-type a passage of text.
## Environment
You will need [Nix][nix] to build this program on your machine. The good news is
that you won't need any Haskell-specific dependencies like `ghc`, `cabal`, or
`stack`: just Nix.
Once you have Nix installed, to build the program, run the following from this
project's top-level directory:
```shell
$ nix-build
```
This should output an executable named `transform-keyboard` within a `result`
directory:
```shell
$ tree result
result
└── transform-keyboard
```
### Testing
To run the test suite, run the following from the project's top-level directory:
```shell
$ nix-shell
$ runhaskell Spec.hs
```
[nix]: https://nixos.org/download.html
## Usage
Here are some `--help` and usage examples:
```shell
$ ./result/transform-keyboard --help
Usage: transform-keyboard (-t|--transforms ARG) (-p|--passage ARG)
Transform a QWERTY keyboard using a string of commands
Available options:
-t,--transforms ARG String of transforms where (e.g. "HHVS12VHVHS3")
-p,--passage ARG Input text to re-type
-h,--help Show this help text
```
Now a working example:
```shell
$ ./result/transform-keyboard --transforms=HHVS12VHVHS3 --passage='Hello,Brilliant.'
Typing: "Hello,Brilliant."
On this keyboard:
[H][J][K][L][;][Q][W][E][R][T]
[Y][U][I][O][P][1][2][3][4][5]
[6][7][8][9][0][Z][X][C][V][B]
[N][M][,][.][/][A][S][D][F][G]
Result: ZIVV4D/O3VV36APF
```
...and an example with an erroneous input (i.e. `!`):
```shell
$ ./result/transform-keyboard --transforms=HHVS12VHVHS3 --passage='Hello,Brilliant!'
Typing: "Hello,Brilliant!"
On this keyboard:
[H][J][K][L][;][Q][W][E][R][T]
[Y][U][I][O][P][1][2][3][4][5]
[6][7][8][9][0][Z][X][C][V][B]
[N][M][,][.][/][A][S][D][F][G]
Looks like at least one of the characters in your input passage doesn't fit on our QWERTY keyboard:
[1][2][3][4][5][6][7][8][9][0]
[Q][W][E][R][T][Y][U][I][O][P]
[A][S][D][F][G][H][J][K][L][;]
[Z][X][C][V][B][N][M][,][.][/]
```

View file

@ -0,0 +1,103 @@
--------------------------------------------------------------------------------
module Spec where
--------------------------------------------------------------------------------
import Test.Hspec
import Test.QuickCheck
import Keyboard (Keyboard(..))
import Transforms (Transform(..))
import Data.Coerce
import Utils
import qualified App
import qualified Keyboard
import qualified Transforms
--------------------------------------------------------------------------------
main :: IO ()
main = hspec $ do
describe "Keyboard.print" $ do
it "pretty-prints the keyboard" $ do
show Keyboard.qwerty == "[1][2][3][4][5][6][7][8][9][0]\n[Q][W][E][R][T][Y][U][I][O][P]\n[A][S][D][F][G][H][J][K][L][;]\n[Z][X][C][V][B][N][M][,][.][/]"
describe "Transforms.fromString" $ do
it "successfully parses a string of commands" $ do
Transforms.fromString "HHVS-12VHVHS3" ==
Just [ HorizontalFlip
, HorizontalFlip
, VerticalFlip
, Shift (-12)
, VerticalFlip
, HorizontalFlip
, VerticalFlip
, HorizontalFlip
, Shift 3
]
it "returns Nothing when the input is invalid" $ do
Transforms.fromString "potato" == Nothing
it "return Nothing when the input is valid except for the end" $ do
Transforms.fromString "HVS10potato" == Nothing
describe "App.transform" $ do
it "flips any keyboard horizontally" $ do
property $ \first second third fourth ->
App.transform (Keyboard [first, second, third, fourth]) HorizontalFlip == do
Keyboard [ reverse first
, reverse second
, reverse third
, reverse fourth
]
it "flips any keyboard vertically" $ do
property $ \first second third fourth ->
App.transform (Keyboard [first, second, third, fourth]) VerticalFlip == do
Keyboard $ reverse [first, second, third, fourth]
it "shifts any keyboard" $ do
property $ \first second third fourth n ->
App.transform (Keyboard [first, second, third, fourth]) (Shift n)
|> (coerce :: Keyboard -> [[Char]])
|> concat ==
[first, second, third, fourth]
|> concat
|> Utils.rotate n
it "flips a QWERTY keyboard horizontally" $ do
App.transform Keyboard.qwerty HorizontalFlip == do
Keyboard [ ['0','9','8','7','6','5','4','3','2','1']
, ['P','O','I','U','Y','T','R','E','W','Q']
, [';','L','K','J','H','G','F','D','S','A']
, ['/','.',',','M','N','B','V','C','X','Z']
]
it "flips a keyboard vertically" $ do
App.transform Keyboard.qwerty VerticalFlip == do
Keyboard [ ['Z','X','C','V','B','N','M',',','.','/']
, ['A','S','D','F','G','H','J','K','L',';']
, ['Q','W','E','R','T','Y','U','I','O','P']
, ['1','2','3','4','5','6','7','8','9','0']
]
it "shifts a keyboard left N times" $ do
App.transform Keyboard.qwerty (Shift 2) == do
Keyboard [ ['3','4','5','6','7','8','9','0','Q','W']
, ['E','R','T','Y','U','I','O','P','A','S']
, ['D','F','G','H','J','K','L',';','Z','X']
, ['C','V','B','N','M',',','.','/','1','2']
]
it "shifts right negative amounts" $ do
App.transform Keyboard.qwerty (Shift (-3)) == do
Keyboard [ [',','.','/','1','2','3','4','5','6','7']
, ['8','9','0','Q','W','E','R','T','Y','U']
, ['I','O','P','A','S','D','F','G','H','J']
, ['K','L',';','Z','X','C','V','B','N','M']
]
describe "Transforms.optimize" $ do
it "removes superfluous horizontal transformations" $ do
Transforms.optimize [HorizontalFlip, HorizontalFlip] == []
it "removes superfluous vertical transformations" $ do
Transforms.optimize [VerticalFlip, VerticalFlip] == []

View file

@ -0,0 +1,52 @@
--------------------------------------------------------------------------------
module Transforms where
--------------------------------------------------------------------------------
import Control.Applicative ((<|>))
import Text.ParserCombinators.ReadP
--------------------------------------------------------------------------------
data Transform = VerticalFlip
| HorizontalFlip
| Shift Int
deriving (Eq, Show)
digit :: ReadP Char
digit =
satisfy (\c -> c >= '0' && c <= '9')
command :: ReadP Transform
command = vertical
<|> horizontal
<|> shift
where
vertical =
char 'V' >> pure VerticalFlip
horizontal =
char 'H' >> pure HorizontalFlip
shift = do
_ <- char 'S'
negative <- option Nothing $ fmap Just (satisfy (== '-'))
n <- read <$> many1 digit
case negative of
Nothing -> pure $ Shift n
Just _ -> pure $ Shift (-1 * n)
-- | Attempt to remove redundant transformations.
-- | Here are some rules that I'd like to support but may not have time for:
-- | - All even-numbered flips (w/o intermittent shifts) can become zero
-- | - All odd-numbered flips (w/o intermittent shifts) can become 1
-- | - All shifts can be be reduce to the absolute value of shifts
optimize :: [Transform] -> [Transform]
optimize [] = []
optimize [x] = [x]
optimize (VerticalFlip:VerticalFlip:xs) = optimize xs
optimize (HorizontalFlip:HorizontalFlip:xs) = optimize xs
optimize xs = xs
fromString :: String -> Maybe [Transform]
fromString x =
case readP_to_S (manyTill command eof) x of
[(res, "")] -> Just res
_ -> Nothing

View file

@ -0,0 +1,13 @@
--------------------------------------------------------------------------------
module Utils where
--------------------------------------------------------------------------------
import Data.Function ((&))
--------------------------------------------------------------------------------
(|>) :: a -> (a -> b) -> b
(|>) = (&)
-- | Rotate `xs` as a cycle `n` times.
rotate :: Int -> [a] -> [a]
rotate n xs = take size . drop (n `mod` size) . cycle $ xs
where size = length xs

View file

@ -0,0 +1,16 @@
let
briefcase = import <briefcase> {};
in briefcase.buildHaskell.program {
name = "transform-keyboard";
srcs = builtins.path {
path = ./.;
name = "transform-keyboard-src";
};
deps = hpkgs: with hpkgs; [
optparse-applicative
unordered-containers
split
rio
];
ghcExtensions = [];
}

View file

@ -0,0 +1,16 @@
let
pkgs = import (builtins.fetchGit {
url = "https://github.com/NixOS/nixpkgs-channels";
ref = "nixos-20.03";
rev = "afa9ca61924f05aacfe495a7ad0fd84709d236cc";
}) {};
in pkgs.mkShell {
buildInputs = with pkgs; [
(haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
hspec
optparse-applicative
unordered-containers
split
]))
];
}

View file

@ -0,0 +1,2 @@
source_up
use_nix

View file

@ -0,0 +1 @@
:set -Wall

View file

@ -0,0 +1,218 @@
{-# LANGUAGE DeriveGeneric #-}
--------------------------------------------------------------------------------
module Main where
--------------------------------------------------------------------------------
import Data.Hashable
import Data.Function ((&))
import GHC.Generics
import Text.ParserCombinators.ReadP
import Control.Applicative
import qualified Data.HashSet as HS
--------------------------------------------------------------------------------
data Direction
= DirLeft
| DirRight
| DirUp
| DirDown
deriving (Eq, Show)
data Point = Point Int Int
deriving (Eq, Show, Ord, Generic)
instance Hashable Point
data Orientation
= Horizontal
| Vertical
deriving (Eq, Show)
data Anchor
= Beg
| End
deriving (Eq, Show)
data Rotation
= CW
| CCW
deriving (Eq, Show)
data Line = Line Point Point
deriving (Show, Generic)
instance Hashable Line
instance Eq Line where
Line begA endA == Line begB endB =
(begA == begB && endA == endB) ||
(begA == endB && endA == begB)
data Game = Game (HS.HashSet Line) [Line]
deriving (Eq, Show)
data Scoreboard = Scoreboard Int Int
deriving (Eq)
instance Semigroup Scoreboard where
(Scoreboard a b) <> (Scoreboard x y) =
Scoreboard (a + x) (b + y)
instance Monoid Scoreboard where
mempty = Scoreboard 0 0
data Turn
= Player1
| Player2
deriving (Eq, Show)
next :: Turn -> Turn
next Player1 = Player2
next Player2 = Player1
instance Show Scoreboard where
show (Scoreboard p1 p2) =
"Player 1: " ++ show (p1) ++ " Player 2: " ++ show (p2)
digit :: ReadP Char
digit = satisfy (\c -> c >= '0' && c <= '9')
int :: ReadP Int
int = read <$> many1 digit
inputLine :: ReadP String
inputLine = manyTill get (char '\n')
direction :: ReadP Direction
direction = do
c <- char 'L' <|> char 'R' <|> char 'U' <|> char 'D'
case c of
'L' -> pure DirLeft
'R' -> pure DirRight
'U' -> pure DirUp
'D' -> pure DirDown
_ -> fail $ "Unexpected direction: " ++ show c
validMove :: Int -> Int -> ReadP Line
validMove w h = do
x <- int
skipSpaces
y <- int
skipSpaces
dir <- direction
_ <- char '\n'
if x >= 0 && x <= w && y >= 0 && y <= h then do
let beg = Point x y
pure $ mkLine beg (shiftPoint dir beg)
else
fail "Expected a move on the game board"
game :: ReadP Game
game = do
w <- read <$> inputLine
h <- read <$> inputLine
locs <- read <$> inputLine
moves <- count locs (validMove w h)
eof
pure $ Game mempty moves
parseInput :: String -> Maybe Game
parseInput x = do
case readP_to_S game x of
[(res, "")] -> Just res
_ -> Nothing
-- | Smart constructor to ensure that beg is always < end.
mkLine :: Point -> Point -> Line
mkLine beg end =
if beg < end then Line beg end else Line end beg
mkLineDir :: Int -> Int -> Direction -> Line
mkLineDir x y dir =
let beg = Point x y
in mkLine beg (shiftPoint dir beg)
mkLineDir' :: Point -> Direction -> Line
mkLineDir' (Point x y) dir = mkLineDir x y dir
shiftPoint :: Direction -> Point -> Point
shiftPoint DirLeft (Point x y) = Point (x - 1) y
shiftPoint DirRight (Point x y) = Point (x + 1) y
shiftPoint DirUp (Point x y) = Point x (y + 1)
shiftPoint DirDown (Point x y) = Point x (y - 1)
shiftLine :: Direction -> Line -> Line
shiftLine dir (Line beg end) =
mkLine (shiftPoint dir beg) (shiftPoint dir end)
rotateLine :: Anchor -> Rotation -> Line -> Line
rotateLine anchor rotation line =
doRotateLine (classifyOrientation line) anchor rotation line
doRotateLine :: Orientation -> Anchor -> Rotation -> Line -> Line
doRotateLine Horizontal Beg CW (Line beg _) = mkLineDir' beg DirDown
doRotateLine Horizontal Beg CCW (Line beg _) = mkLineDir' beg DirUp
doRotateLine Horizontal End CW (Line _ end) = mkLineDir' end DirUp
doRotateLine Horizontal End CCW (Line _ end) = mkLineDir' end DirDown
doRotateLine Vertical Beg CW (Line beg _) = mkLineDir' beg DirRight
doRotateLine Vertical Beg CCW (Line beg _) = mkLineDir' beg DirLeft
doRotateLine Vertical End CW (Line _ end) = mkLineDir' end DirLeft
doRotateLine Vertical End CCW (Line _ end) = mkLineDir' end DirRight
classifyOrientation :: Line -> Orientation
classifyOrientation (Line (Point _ y1) (Point _ y2)) =
if y1 == y2 then Horizontal else Vertical
closesAnySquare :: HS.HashSet Line -> Line -> Bool
closesAnySquare allMoves line = do
let alreadyDrawn x = HS.member x allMoves
case classifyOrientation line of
Horizontal ->
all alreadyDrawn
[ shiftLine DirUp line
, rotateLine Beg CCW line
, rotateLine End CW line
] ||
all alreadyDrawn
[ shiftLine DirDown line
, rotateLine Beg CW line
, rotateLine End CCW line
]
Vertical ->
all alreadyDrawn
[ shiftLine DirLeft line
, rotateLine Beg CCW line
, rotateLine End CW line
] ||
all alreadyDrawn
[ shiftLine DirRight line
, rotateLine Beg CW line
, rotateLine End CCW line
]
incScoreboard :: Turn -> Scoreboard -> Scoreboard
incScoreboard Player1 score = score <> Scoreboard 1 0
incScoreboard Player2 score = score <> Scoreboard 0 1
scoreGame :: Turn -> Game -> Scoreboard -> Maybe Scoreboard
scoreGame _ (Game _ []) score = Just $ score
scoreGame player (Game allMoves (line:rest)) score =
if HS.member line allMoves then
Nothing
else do
let allMoves' = HS.insert line allMoves
score' = if closesAnySquare allMoves line then
incScoreboard player score
else score
scoreGame (next player) (Game allMoves' rest) score'
(|>) :: a -> (a -> b) -> b
(|>) = (&)
main :: IO ()
main = do
input <- readFile "game.txt"
case parseInput input of
Nothing -> putStrLn "invalid"
Just parsedGame ->
case scoreGame Player1 parsedGame mempty of
Nothing -> putStrLn "invalid"
Just score -> print score

View file

@ -0,0 +1,21 @@
# Dotted Squares
This is my second attempt at solving this problem. I had an hour to solve it the
first time, and I unfortunately came up short although I made good progress.
The problem asks to read input from a text file that looks like this:
```
1 -- board width
1 -- board height
4 -- number of lines of "moves" (below)
0 0 R -- create a unit vector (0,0) facing right
0 0 U -- create a unit vector (0,0) facing up
0 1 L -- create a unit vector (0,1) facing left
1 1 D -- create a unit vector (1,1) facing down
```
After parsing and validating the input, score the outcome a game where players
one and two alternatively take turns drawing lines on a board. Anytime one of
the players draws a line that creates a square from existing lines, they get a
point.

View file

@ -0,0 +1,80 @@
--------------------------------------------------------------------------------
module Spec where
--------------------------------------------------------------------------------
import Test.Hspec
import Main hiding (main)
import qualified Data.HashSet as HS
--------------------------------------------------------------------------------
main :: IO ()
main = hspec $ do
describe "dotted-squares" $ do
describe "parseInput" $ do
it "works as expected" $ do
input <- readFile "input-a.txt"
parseInput input `shouldBe` Just (Game mempty [ mkLine (Point 0 0) (Point 1 0)
, mkLine (Point 0 0) (Point 0 1)
])
it "fails when the game has too many user moves" $ do
input <- readFile "too-many-moves.txt"
parseInput input `shouldBe` Nothing
it "fails when the game has too few user moves" $ do
input <- readFile "too-few-moves.txt"
parseInput input `shouldBe` Nothing
describe "shiftLine" $ do
let horizontal = mkLineDir 1 1 DirRight
vertical = mkLineDir 1 1 DirUp
it "can move a horizontal line up" $
shiftLine DirUp horizontal `shouldBe` mkLineDir 1 2 DirRight
it "can move a horizontal line down" $
shiftLine DirDown horizontal `shouldBe` mkLineDir 1 0 DirRight
it "can move a horizontal line left" $
shiftLine DirLeft horizontal `shouldBe` mkLineDir 0 1 DirRight
it "can move a horizontal line right" $
shiftLine DirRight horizontal `shouldBe` mkLineDir 2 1 DirRight
it "can move a vertical line up" $
shiftLine DirUp vertical `shouldBe` mkLineDir 1 2 DirUp
it "can move a vertical line down" $
shiftLine DirDown vertical `shouldBe` mkLineDir 1 0 DirUp
it "can move a vertical line left" $
shiftLine DirLeft vertical `shouldBe` mkLineDir 0 1 DirUp
it "can move a vertical line right" $
shiftLine DirRight vertical `shouldBe` mkLineDir 2 1 DirUp
describe "rotateLine" $ do
let horizontal = mkLineDir 1 1 DirRight -- 1,1;2,1
vertical = mkLineDir 1 1 DirUp -- 1,1;1,2
it "can rotate a horizontal line CW anchored at its beginning" $
rotateLine Beg CW horizontal `shouldBe` mkLineDir 1 1 DirDown
it "can rotate a horizontal line CCW anchored at its beginning" $
rotateLine Beg CCW horizontal `shouldBe` mkLineDir 1 1 DirUp
it "can rotate a horizontal line CW anchored at its end" $
rotateLine End CW horizontal `shouldBe` mkLineDir 2 1 DirUp
it "can rotate a horizontal line CCW anchored at its end" $
rotateLine End CCW horizontal `shouldBe` mkLineDir 2 1 DirDown
it "can rotate a vertical line CW anchored at its beginning" $
rotateLine Beg CW vertical `shouldBe` mkLineDir 1 1 DirRight
it "can rotate a vertical line CCW anchored at its beginning" $
rotateLine Beg CCW vertical `shouldBe` mkLineDir 1 1 DirLeft
it "can rotate a vertical line CW anchored at its end" $
rotateLine End CW vertical `shouldBe` mkLineDir 1 2 DirLeft
it "can rotate a vertical line CCW anchored at its end" $
rotateLine End CCW vertical `shouldBe` mkLineDir 1 2 DirRight
describe "closesAnySquare" $ do
let threeSides = [ (0, 0, DirRight)
, (0, 0, DirUp)
, (0, 1, DirRight)
]
|> fmap (\(x, y, dir) -> mkLineDir x y dir)
|> HS.fromList
it "returns true the line we supply makes a square" $
closesAnySquare threeSides (mkLineDir 1 1 DirDown) `shouldBe` True
it "returns false the line we supply doesn't make a square" $
closesAnySquare threeSides (mkLineDir 1 1 DirUp) `shouldBe` False
it "returns false when we have no existing lines" $
closesAnySquare mempty (mkLineDir 1 1 DirUp) `shouldBe` False

View file

@ -0,0 +1,7 @@
1
1
4
0 0 R
0 0 R
0 1 R
0 1 R

View file

@ -0,0 +1,7 @@
1
1
4
0 0 R
0 0 U
0 1 R
1 1 D

View file

@ -0,0 +1,5 @@
1
1
2
0 0 R
0 0 U

View file

@ -0,0 +1,8 @@
let
briefcase = import <briefcase> {};
in briefcase.buildHaskell.shell {
deps = hpkgs: with hpkgs; [
hspec
unordered-containers
];
}

View file

@ -0,0 +1,6 @@
1
1
4
0 0 R
0 0 U
0 1 R

View file

@ -0,0 +1,7 @@
1
1
3
0 0 R
0 0 U
0 1 R
1 1 D

View file

@ -0,0 +1,29 @@
# The file '2010.census.txt' contains summary statistics from the 2010 United
# States census including household income. The data is in an unspecified
# format.
# Find the average of the column called:
# 'MEDIAN HOUSEHOLD INCOME'
# Ideally the solution should be a command line script, of the form:
# $ ./solution [options] [file...]
# The solution may be written in any language, Python is preferred but not
# required.
# Google, stack overflow, etc. usage is allowed.
import requests
url = "https://assets.tryramp.com/interview/census/2010.census.txt"
def main():
res = requests.get(url)
if res.status not in {200}:
raise Exception("Unexpected status code: {}".format(res.status_code))
# download the content
# parse row
# select 'MEDIAN HOUSEHOLD INCOME' column
pass

View file

@ -0,0 +1,87 @@
# The file '2010.census.txt' contains summary statistics from the 2010 United
# States census including household income. The data is in an unspecified
# format.
# Find the average of the column called:
# 'MEDIAN HOUSEHOLD INCOME'
# Ideally the solution should be a command line script, of the form:
# $ ./solution [options] [file...]
# The solution may be written in any language, Python is preferred but not
# required.
# Google, stack overflow, etc. usage is allowed.
import requests
import csv
url = "https://assets.tryramp.com/interview/census/2010.census.txt"
column = 'MEDIAN HOUSEHOLD INCOME'
columns = [
'CENSUS YEAR',
'TRACT',
'BLOCK GROUP',
'FIPS ID',
'TOTAL POPULATION',
'POPULATION WHITE',
'POPULATION BLACK',
'POPULATION ASIAN',
'POPULATION OTHER',
'POPULATION AMERICAN INDIAN',
'POPULATION PACIFIC ISLANDER',
'POPULATION ONE RACE',
'POPULATION MULTI RACE',
'POPULATION 25 OLDER',
'MEDIAN AGE',
'MEDIAN HOUSEHOLD INCOME',
'HIGH SCHOOL MALE',
'HIGH SCHOOL MORE MALE',
'COLLEGE 1 YR LESS MALE',
'COLLEGE 1 YR MORE MALE',
'ASSOCIATES DEGREE MALE',
'BACHELORS DEGREE MALE',
'MASTERS DEGREE MALE',
'PROFESSIONAL DEGREE MALE',
'DOCTORAL DEGREE MALE',
'HIGH SCHOOL FEMALE',
'HIGH SCHOOL MORE FEMALE',
'COLLEGE 1 YR LESS FEMALE',
'COLLEGE 1 YR MORE FEMALE',
'ASSOCIATES DEGREE FEMALE',
'BACHELORS DEGREE FEMALE',
'MASTERS DEGREE FEMALE',
'PROFESSIONAL DEGREE FEMALE',
'DOCTORAL DEGREE FEMALE',
'PERCENT 25 YR OVER HIGH SCHOOL MORE',
'HOUSING UNITS',
'OCCUPIED HOUSING UNITS',
'OWNER OCCUPIED HOUSING',
'RENTER OCCUPIED HOUSING',
'PERCENT OWNER OCCUPIED',
'PERCENT RENTER OCCUPIED',
'MEDIAN HOUSE VALUE OWNER OCCUPIED',
'MEDIAN YEAR BUILT',
'VACANCY RATES',
]
def average(xs):
return sum(xs) / len(xs)
def parse_body(body):
return list(csv.DictReader(body.split('\n')[1:], delimiter='|', fieldnames=columns))
def main():
res = requests.get(url)
if res.status_code not in {200}:
raise Exception("Unexpected status code: {}".format(res.status_code))
return average([int(d.get(column))
for d in parse_body(res.text)
if int(d.get(column)) >= 0])
print(main())

View file

@ -0,0 +1 @@
default.nix

View file

@ -0,0 +1,44 @@
# Semiprimes Service
## Introduction
A **composite** is a number containing at least two prime factors. For example:
```
15 = 3 × 5
9 = 3 × 3
12 = 2 × 2 × 3
```
There are ten composites below thirty containing precisely two, not necessarily
distinct, prime factors: `4, 6, 9, 10, 14, 15, 21, 22, 25, 26`. Lets call such
numbers *Semiprimes*.
## Task
- Write a module which provides a function to tell whether a given number, `N`,
is a semiprime. `N` will be less than 100,000
- Please implement an API (RESTful or GraphQL) to factor a given number into two
prime numbers if its a semiprime, otherwise, return an error message.
## Stretch Goals
- Handle the invalid inputs.
- Support batch requests: i.e. users could provide 100 numbers, and the API
return the answer for all.
- Considering this module will be used by a long running service, could you
optimize it to give answers faster?
## Usage
To run the application you'll need to have `elixir` installed. Assuming `elixir`
is already installed, consult the following steps to start the application:
```shell
$ cd server
$ mix deps.get
$ iex -S mix
```
Now open a web browser and visit `http://localhost:8080`!

View file

@ -0,0 +1 @@
# stubbed

View file

@ -0,0 +1,4 @@
# Used by "mix format"
[
inputs: ["{mix,.formatter}.exs", "{config,lib,test}/**/*.{ex,exs}"]
]

View file

@ -0,0 +1,24 @@
# The directory Mix will write compiled artifacts to.
/_build/
# If you run "mix test --cover", coverage assets end up here.
/cover/
# The directory Mix downloads your dependencies sources to.
/deps/
# Where third-party dependencies like ExDoc output generated docs.
/doc/
# Ignore .fetch files in case you like to edit your project deps locally.
/.fetch
# If the VM crashes, it generates a dump, let's ignore it too.
erl_crash.dump
# Also ignore archive artifacts (built via "mix archive.build").
*.ez
# Ignore package tarball (built via "mix hex.build").
server-*.tar

View file

@ -0,0 +1,8 @@
defmodule App do
use Application
@impl true
def start(_type, _args) do
Sup.start_link()
end
end

View file

@ -0,0 +1,41 @@
defmodule Cache do
@moduledoc """
Cache is an in-memory key-value store.
"""
use Agent
@doc """
Inititalize the key-value store.
"""
def start_link(_) do
Agent.start_link(fn -> %{} end, name: __MODULE__)
end
@doc """
Attempt to return the value stored at `key`
"""
def get(key) do
Agent.get(__MODULE__, &Map.get(&1, key))
end
@doc """
Write the `value` under the `key`. Last writer wins.
"""
def put(key, value) do
Agent.update(__MODULE__, &Map.put(&1, key, value))
end
@doc """
List the contents of the cache. Useful for debugging purposes.
"""
def list() do
Agent.get(__MODULE__, & &1)
end
@doc """
Invalidate the entire cache.
"""
def clear() do
Agent.update(__MODULE__, fn _ -> %{} end)
end
end

View file

@ -0,0 +1,22 @@
defmodule Extras do
@moduledoc """
Hosts utility functions intended to supplement the standard library.
"""
@doc """
Return an ascending range starting at `a` and ending at `b` (exclusive).
## Examples
iex> Extras.range(2, 5)
[2, 3, 4]
"""
def range(a, b) do
if b <= a do
[]
else
[a] ++ range(a + 1, b)
end
end
end

View file

@ -0,0 +1,26 @@
defmodule Math do
@moduledoc """
Math utilities.
"""
alias Extras
@doc """
Returns the prime factors for `n`.
## Examples
iex> Math.factor(15)
[3, 5]
"""
def factor(1), do: []
def factor(n) do
Extras.range(2, n - 1)
|> Enum.find(&(rem(n, &1) == 0))
|> case do
nil -> [n]
x -> [x | factor(div(n, x))]
end
end
end

View file

@ -0,0 +1,86 @@
defmodule Router do
use Plug.Router
use Plug.Debugger
require Logger
plug(Plug.Logger, log: :debug)
plug(Plug.Parsers, parsers: [:urlencoded])
plug(:match)
plug(:dispatch)
@usage """
Usage: Try querying some of the following endpoints...
GET /
GET /help
GET /semiprime?number=<integer>
GET /semiprimes?numbers=<comma-separated-integers>
"""
get "/" do
send_resp(conn, 200, "Welcome to Semiprimes Service!\n\n#{@usage}")
end
get "/help" do
send_resp(conn, 200, @usage)
end
get "/semiprime" do
case conn |> Map.get(:query_params) |> Map.get("number") do
nil ->
send_resp(conn, 400, "You must pass an integer as a query parameter. #{@usage}")
val ->
case Integer.parse(val) do
{n, ""} ->
send_resp(conn, 200, semiprime_response(n))
_ ->
send_resp(conn, 400, "We could not parse the number you provided.\n\n#{@usage}")
end
end
end
get "/semiprimes" do
case conn |> Map.get(:query_params) |> Map.get("numbers") do
nil ->
send_resp(
conn,
400,
"You must pass a comma-separated list of integers as a query parameter.\n\n#{@usage}"
)
xs ->
response =
xs
|> String.split(",")
|> Stream.map(&Integer.parse/1)
|> Stream.filter(fn
{n, ""} -> true
_ -> false
end)
|> Stream.map(fn {n, ""} -> semiprime_response(n) end)
|> Enum.join("\n")
send_resp(conn, 200, response)
end
end
match _ do
send_resp(conn, 404, "Not found.")
end
################################################################################
# Utils
################################################################################
defp semiprime_response(n) do
case Server.semiprime(n) do
nil ->
"#{n} is not a semiprime. Try another number!"
{hit_or_miss, factors} ->
response = "#{n} is a semiprime! Its factors are #{Enum.join(factors, " and ")}."
"Cache #{Atom.to_string(hit_or_miss)} - #{response}"
end
end
end

View file

@ -0,0 +1,33 @@
defmodule Server do
@moduledoc """
Documentation for `Server`.
"""
@doc """
If `n` contains exactly two prime factors, return those prime factors;
otherwise, return nothing.
"""
def semiprime(n) do
case Cache.get(n) do
nil ->
case do_semiprime(n) do
nil ->
nil
res ->
Cache.put(n, res)
{:miss, res}
end
hit ->
{:hit, hit}
end
end
defp do_semiprime(n) do
case Math.factor(n) do
[_, _] = res -> res
_ -> nil
end
end
end

View file

@ -0,0 +1,23 @@
defmodule Sup do
@moduledoc """
Top-level supervisor for our OTP application. For now, this supervisor starts
and monitors our cache.
"""
use Supervisor
alias Plug.Adapters.Cowboy
def start_link(opts \\ []) do
Supervisor.start_link(__MODULE__, :ok, opts)
end
@impl true
def init(:ok) do
children = [
Cache,
Cowboy.child_spec(scheme: :http, plug: Router, options: [port: 8000])
]
Supervisor.init(children, strategy: :one_for_one)
end
end

View file

@ -0,0 +1,32 @@
defmodule Server.MixProject do
use Mix.Project
def project do
[
app: :server,
version: "0.1.0",
elixir: "~> 1.10",
start_permanent: Mix.env() == :prod,
deps: deps()
]
end
# Run "mix help compile.app" to learn about applications.
def application do
[
extra_applications: [:logger],
mod: {App, []}
]
end
# Run "mix help deps" to learn about dependencies.
defp deps do
[
{:cortex, "~> 0.1", only: [:dev, :test]},
{:plug_cowboy, "~> 2.4.1"},
{:cowboy, "~> 2.8.0"},
{:plug, "~> 1.11.0"},
{:poison, "~> 4.0.1"}
]
end
end

View file

@ -0,0 +1,14 @@
%{
"cortex": {:hex, :cortex, "0.6.0", "8094830fae266eb0ae34d1a58983c0c49484341f5044fb4dfb81746647bd2993", [:mix], [{:file_system, "~> 0.2", [hex: :file_system, repo: "hexpm", optional: false]}], "hexpm", "d0ef5a2b1269626149118684dc4ea77dbfbc67017f4b4065b71dcefa26cfcc49"},
"cowboy": {:hex, :cowboy, "2.8.0", "f3dc62e35797ecd9ac1b50db74611193c29815401e53bac9a5c0577bd7bc667d", [:rebar3], [{:cowlib, "~> 2.9.1", [hex: :cowlib, repo: "hexpm", optional: false]}, {:ranch, "~> 1.7.1", [hex: :ranch, repo: "hexpm", optional: false]}], "hexpm", "4643e4fba74ac96d4d152c75803de6fad0b3fa5df354c71afdd6cbeeb15fac8a"},
"cowboy_telemetry": {:hex, :cowboy_telemetry, "0.3.1", "ebd1a1d7aff97f27c66654e78ece187abdc646992714164380d8a041eda16754", [:rebar3], [{:cowboy, "~> 2.7", [hex: :cowboy, repo: "hexpm", optional: false]}, {:telemetry, "~> 0.4", [hex: :telemetry, repo: "hexpm", optional: false]}], "hexpm", "3a6efd3366130eab84ca372cbd4a7d3c3a97bdfcfb4911233b035d117063f0af"},
"cowlib": {:hex, :cowlib, "2.9.1", "61a6c7c50cf07fdd24b2f45b89500bb93b6686579b069a89f88cb211e1125c78", [:rebar3], [], "hexpm", "e4175dc240a70d996156160891e1c62238ede1729e45740bdd38064dad476170"},
"file_system": {:hex, :file_system, "0.2.10", "fb082005a9cd1711c05b5248710f8826b02d7d1784e7c3451f9c1231d4fc162d", [:mix], [], "hexpm", "41195edbfb562a593726eda3b3e8b103a309b733ad25f3d642ba49696bf715dc"},
"mime": {:hex, :mime, "1.5.0", "203ef35ef3389aae6d361918bf3f952fa17a09e8e43b5aa592b93eba05d0fb8d", [:mix], [], "hexpm", "55a94c0f552249fc1a3dd9cd2d3ab9de9d3c89b559c2bd01121f824834f24746"},
"plug": {:hex, :plug, "1.11.0", "f17217525597628298998bc3baed9f8ea1fa3f1160aa9871aee6df47a6e4d38e", [:mix], [{:mime, "~> 1.0", [hex: :mime, repo: "hexpm", optional: false]}, {:plug_crypto, "~> 1.1.1 or ~> 1.2", [hex: :plug_crypto, repo: "hexpm", optional: false]}, {:telemetry, "~> 0.4", [hex: :telemetry, repo: "hexpm", optional: false]}], "hexpm", "2d9c633f0499f9dc5c2fd069161af4e2e7756890b81adcbb2ceaa074e8308876"},
"plug_cowboy": {:hex, :plug_cowboy, "2.4.1", "779ba386c0915027f22e14a48919a9545714f849505fa15af2631a0d298abf0f", [:mix], [{:cowboy, "~> 2.7", [hex: :cowboy, repo: "hexpm", optional: false]}, {:cowboy_telemetry, "~> 0.3", [hex: :cowboy_telemetry, repo: "hexpm", optional: false]}, {:plug, "~> 1.7", [hex: :plug, repo: "hexpm", optional: false]}, {:telemetry, "~> 0.4", [hex: :telemetry, repo: "hexpm", optional: false]}], "hexpm", "d72113b6dff7b37a7d9b2a5b68892808e3a9a752f2bf7e503240945385b70507"},
"plug_crypto": {:hex, :plug_crypto, "1.2.0", "1cb20793aa63a6c619dd18bb33d7a3aa94818e5fd39ad357051a67f26dfa2df6", [:mix], [], "hexpm", "a48b538ae8bf381ffac344520755f3007cc10bd8e90b240af98ea29b69683fc2"},
"poison": {:hex, :poison, "4.0.1", "bcb755a16fac91cad79bfe9fc3585bb07b9331e50cfe3420a24bcc2d735709ae", [:mix], [], "hexpm", "ba8836feea4b394bb718a161fc59a288fe0109b5006d6bdf97b6badfcf6f0f25"},
"ranch": {:hex, :ranch, "1.7.1", "6b1fab51b49196860b733a49c07604465a47bdb78aa10c1c16a3d199f7f8c881", [:rebar3], [], "hexpm", "451d8527787df716d99dc36162fca05934915db0b6141bbdac2ea8d3c7afc7d7"},
"telemetry": {:hex, :telemetry, "0.4.2", "2808c992455e08d6177322f14d3bdb6b625fbcfd233a73505870d8738a2f4599", [:rebar3], [], "hexpm", "2d1419bd9dda6a206d7b5852179511722e2b18812310d304620c7bd92a13fcef"},
}

View file

@ -0,0 +1,18 @@
defmodule ExtrasTest do
use ExUnit.Case
doctest Extras
describe "range" do
test "returns an empty list for descending sequences" do
assert Extras.range(0, -2) == []
end
test "returns an empty list for non-ascending sequences" do
assert Extras.range(8, 8) == []
end
test "returns an exclusive range" do
assert Extras.range(3, 6) == [3, 4, 5]
end
end
end

View file

@ -0,0 +1,30 @@
defmodule MathTest do
use ExUnit.Case
doctest Math
describe "factor" do
test "returns the prime factors for an input" do
[
{15, [3, 5]},
{12, [2, 2, 3]},
{9, [3, 3]},
{21, [3, 7]}
]
|> Enum.map(fn {input, expected} ->
assert Math.factor(input) == expected
end)
end
test "handles large numbers" do
assert Math.factor(104_023) == [17, 29, 211]
end
test "returns an empty list for 1" do
assert Math.factor(1) == []
end
test "returns the prime number itself when the input is prime" do
assert Math.factor(7) == [7]
end
end
end

View file

@ -0,0 +1,34 @@
defmodule ServerTest do
use ExUnit.Case
doctest Server
describe "semiprime" do
test "returns the factors when the number is semiprime" do
Cache.clear()
# Semiprimes below 30
[
{4, [2, 2]},
{6, [2, 3]},
{9, [3, 3]},
{10, [2, 5]},
{14, [2, 7]},
{15, [3, 5]},
{21, [3, 7]},
{22, [2, 11]},
{25, [5, 5]},
{26, [2, 13]}
]
|> Enum.each(fn {input, expected} ->
assert Server.semiprime(input) == {:miss, expected}
end)
end
test "returns nothing when the number is a composite number" do
# Composite numbers below 30
[1, 2, 3, 5, 7, 8, 11, 12, 13, 16, 17, 18, 19, 20, 23, 24, 27, 28, 29]
|> Enum.each(fn x ->
assert Server.semiprime(x) == nil
end)
end
end
end

View file

@ -0,0 +1 @@
ExUnit.start()

View file

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

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

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

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

View file

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

View file

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

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

View file

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

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)

View file

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

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

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

View file

@ -0,0 +1,21 @@
# Boilerplate
Storing some boilerplate code to help me reduce the time it takes me to develop
and deploy applications.
## Usage
Let's say that you would like to create a game for
`sandbox.wpcarro.dev/game`. We will create a new TypeScript project with the
following:
```shell
$ cp ~/briefcase/boilerplate/typescript ~/briefcase/website/sandbox/game
```
This initializes the project. To start developing, run:
```shell
$ nix-shell
$ yarn run dev
```

View file

@ -0,0 +1,2 @@
source_up
use_nix

View file

@ -0,0 +1,4 @@
/.lein-repl-history
/target
/?
/.nrepl-port

View file

@ -0,0 +1,33 @@
# Clojure Boilerplate
This boilerplate uses `lein` to manage the project.
## Files to change
To use this boilerplate, run the following in a shell:
```shell
$ cp ~/briefcase/boilerplate/clojure path/to/new-project
```
After running the above command, change the following files to remove the
placeholder values:
- `README.md`: Change the title; change the description; drop "Files to change";
keep "Getting started"
- `project.clj`: Change title
- `src/main.clj`: Change `:doc`; drop `main/foo`
## Getting started
From a shell, run:
```shell
$ lein repl
```
From Emacs, navigate to a source code buffer and run:
```
M-x cider-jack-in
```

View file

@ -0,0 +1,2 @@
(defproject boilerplate "0.0.1"
:dependencies [[org.clojure/clojure "1.8.0"]])

View file

@ -0,0 +1,8 @@
let
briefcase = import <briefcase> {};
pkgs = briefcase.third_party.pkgs;
in pkgs.mkShell {
buildInputs = with pkgs; [
leiningen
];
}

View file

@ -0,0 +1,8 @@
(ns ^{:doc "Top-level module."
:author "William Carroll"}
main)
(declare main)
(defn foo [a b]
(+ a b))

View file

@ -0,0 +1,2 @@
source_up
use_nix

Some files were not shown because too many files have changed in this diff Show more