mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Support creating Trips from the frontend

Browse source 
*sigh* ... spent way too much time encoding/decoding date types...

I need my database, server, client, and JSON need to agree on types.

TL;DR:
- Add CSS for elm/datepicker library
- Create Common.allErrors to display UI errors
- Prefer Data.Time.Calendar.Day instead of newtype Date wrapper around Text
This commit is contained in:
William Carroll 2020-08-01 23:04:06 +01:00
parent 54eb29eae0
commit 249e3113ff
10 changed files with 534 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
client/elm.json
View file

@ -6,6 +6,7 @@
"elm-version": "0.19.1",
"dependencies": {
"direct": {
"CurrySoftware/elm-datepicker": "4.0.0",
"elm/browser": "1.0.2",
"elm/core": "1.0.5",
"elm/html": "1.0.0",
@ -19,6 +20,7 @@
"elm-community/list-extra": "8.2.3",
"elm-community/maybe-extra": "5.2.0",
"elm-community/random-extra": "3.1.0",
"justinmimbs/date": "3.2.1",
"krisajenkins/remotedata": "6.0.1",
"ryannhg/date-format": "2.3.0"
},

139
client/index.css
View file

@ -1,3 +1,142 @@
@tailwind base;
@tailwind components;
@tailwind utilities;
.elm-datepicker--container {
position: relative;
}
.elm-datepicker--input:focus {
outline: 0;
}
.elm-datepicker--picker {
position: absolute;
border: 1px solid #CCC;
z-index: 10;
background-color: white;
}
.elm-datepicker--picker-header,
.elm-datepicker--weekdays {
background: #F2F2F2;
}
.elm-datepicker--picker-header {
display: flex;
align-items: center;
}
.elm-datepicker--prev-container,
.elm-datepicker--next-container {
flex: 0 1 auto;
cursor: pointer;
}
.elm-datepicker--month-container {
flex: 1 1 auto;
padding: 0.5em;
display: flex;
flex-direction: column;
}
.elm-datepicker--month,
.elm-datepicker--year {
flex: 1 1 auto;
cursor: default;
text-align: center;
}
.elm-datepicker--year {
font-size: 0.6em;
font-weight: 700;
}
.elm-datepicker--prev,
.elm-datepicker--next {
border: 6px solid transparent;
background-color: inherit;
display: block;
width: 0;
height: 0;
padding: 0 0.2em;
}
.elm-datepicker--prev {
border-right-color: #AAA;
}
.elm-datepicker--prev:hover {
border-right-color: #BBB;
}
.elm-datepicker--next {
border-left-color: #AAA;
}
.elm-datepicker--next:hover {
border-left-color: #BBB;
}
.elm-datepicker--table {
border-spacing: 0;
border-collapse: collapse;
font-size: 0.8em;
}
.elm-datepicker--table td {
width: 2em;
height: 2em;
text-align: center;
}
.elm-datepicker--row {
border-top: 1px solid #F2F2F2;
}
.elm-datepicker--dow {
border-bottom: 1px solid #CCC;
cursor: default;
}
.elm-datepicker--day {
cursor: pointer;
}
.elm-datepicker--day:hover {
background: #F2F2F2;
}
.elm-datepicker--disabled {
cursor: default;
color: #DDD;
}
.elm-datepicker--disabled:hover {
background: inherit;
}
.elm-datepicker--picked {
color: white;
background: darkblue;
}
.elm-datepicker--picked:hover {
background: darkblue;
}
.elm-datepicker--today {
font-weight: bold;
}
.elm-datepicker--other-month {
color: #AAA;
}
.elm-datepicker--other-month.elm-datepicker--disabled {
color: #EEE;
}
.elm-datepicker--other-month.elm-datepicker--picked {
color: white;
}

20
client/src/Admin.elm
View file

@ -5,6 +5,7 @@ import Html.Attributes exposing (..)
import Html.Events exposing (..)
import RemoteData
import State
import Common
import Tailwind
import UI
import Utils
@ -78,22 +79,5 @@ render model =
, case model.adminTab of
State.Users ->
allUsers model
, case model.logoutError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error logging out"
, body = Utils.explainHttpError e
}
, case model.deleteUserError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error attempting to delete user"
, body = Utils.explainHttpError e
}
, Common.allErrors model
]

27
client/src/Common.elm Normal file
View file

@ -0,0 +1,27 @@
module Common exposing (..)
import Html exposing (..)
import Maybe.Extra as ME
import State
import UI
import Utils
allErrors : State.Model -> Html State.Msg
allErrors model =
div []
(State.allErrors
model
|> List.map
(\( mError, title ) ->
case mError of
Nothing ->
text ""
Just err ->
UI.errorBanner
{ title = title
, body = Utils.explainHttpError err
}
)
)

30
client/src/Login.elm
View file

@ -1,5 +1,6 @@
module Login exposing (render)
import Common
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
@ -137,24 +138,7 @@ login model =
]
[ UI.header 3 "Welcome to Trip Planner"
, loginForm model
, case model.loginError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error logging in"
, body = Utils.explainHttpError e
}
, case model.signUpError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error creating account"
, body = Utils.explainHttpError e
}
, Common.allErrors model
]
@ -174,15 +158,7 @@ logout model =
{ label = "Logout"
, handleClick = State.AttemptLogout
}
, case model.logoutError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error logging out"
, body = Utils.explainHttpError e
}
, Common.allErrors model
]

11
client/src/Manager.elm
View file

@ -1,6 +1,7 @@
module Manager exposing (render)
import Array
import Common
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
@ -33,14 +34,6 @@ render model =
{ label = "Logout"
, handleClick = State.AttemptLogout
}
, case model.logoutError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error logging out"
, body = Utils.explainHttpError e
}
, Common.allErrors model
]
]

242
client/src/State.elm
View file

@ -3,6 +3,8 @@ module State exposing (..)
import Array exposing (Array)
import Browser
import Browser.Navigation as Nav
import Date
import DatePicker
import Http
import Json.Decode as JD
import Json.Decode.Extra as JDE
@ -31,6 +33,10 @@ type Msg
| UpdatePassword String
| UpdateRole String
| UpdateAdminTab AdminTab
| UpdateTripDestination String
| UpdateTripStartDate DatePicker.Msg
| UpdateTripEndDate DatePicker.Msg
| UpdateTripComment String
| ClearErrors
| ToggleLoginForm
-- SPA
@ -42,12 +48,15 @@ type Msg
| AttemptLogin
| AttemptLogout
| AttemptDeleteUser String
| AttemptCreateTrip Date.Date Date.Date
-- Inbound network
| GotUsers (WebData AllUsers)
| GotTrips (WebData (List Trip))
| GotSignUp (Result Http.Error Session)
| GotLogin (Result Http.Error Session)
| GotLogout (Result Http.Error String)
| GotDeleteUser (Result Http.Error String)
| CreatedTrip (Result Http.Error ())
type Route
@ -85,13 +94,6 @@ type alias Review =
}
type alias Reviews =
{ hi : Maybe Review
, lo : Maybe Review
, all : List Review
}
type AdminTab
= Users
@ -101,6 +103,14 @@ type LoginTab
| SignUpForm
type alias Trip =
{ destination : String
, startDate : Date.Date
, endDate : Date.Date
, comment : String
}
type alias Model =
{ route : Maybe Route
, url : Url.Url
@ -111,15 +121,33 @@ type alias Model =
, password : String
, role : Maybe Role
, users : WebData AllUsers
, startDatePicker : DatePicker.DatePicker
, endDatePicker : DatePicker.DatePicker
, tripDestination : String
, tripStartDate : Maybe Date.Date
, tripEndDate : Maybe Date.Date
, tripComment : String
, trips : WebData (List Trip)
, adminTab : AdminTab
, loginTab : LoginTab
, loginError : Maybe Http.Error
, logoutError : Maybe Http.Error
, signUpError : Maybe Http.Error
, deleteUserError : Maybe Http.Error
, createTripError : Maybe Http.Error
}
allErrors : Model -> List ( Maybe Http.Error, String )
allErrors model =
[ ( model.loginError, "Error attempting to authenticate" )
, ( model.logoutError, "Error attempting to log out" )
, ( model.signUpError, "Error attempting to create your account" )
, ( model.deleteUserError, "Error attempting to delete a user" )
, ( model.createTripError, "Error attempting to create a trip" )
]
--------------------------------------------------------------------------------
-- Functions
@ -220,6 +248,31 @@ signUp { username, email, password } =
}
createTrip :
{ username : String
, destination : String
, startDate : Date.Date
, endDate : Date.Date
, comment : String
}
-> Cmd Msg
createTrip { username, destination, startDate, endDate, comment } =
Utils.postWithCredentials
{ url = endpoint [ "trips" ] []
, body =
Http.jsonBody
(JE.object
[ ( "username", JE.string username )
, ( "destination", JE.string destination )
, ( "startDate", encodeDate startDate )
, ( "endDate", encodeDate endDate )
, ( "comment", JE.string comment )
]
)
, expect = Http.expectWhatever CreatedTrip
}
deleteUser : String -> Cmd Msg
deleteUser username =
Utils.deleteWithCredentials
@ -239,6 +292,35 @@ decodeReview =
(JD.field "timestamp" JD.string)
encodeDate : Date.Date -> JE.Value
encodeDate date =
date |> Date.toIsoString |> JE.string
decodeDate : JD.Decoder Date.Date
decodeDate =
JD.string |> JD.andThen (Date.fromIsoString >> JDE.fromResult)
fetchTrips : Cmd Msg
fetchTrips =
Utils.getWithCredentials
{ url = endpoint [ "trips" ] []
, expect =
Http.expectJson
(RemoteData.fromResult >> GotTrips)
(JD.list
(JD.map4
Trip
(JD.field "destination" JD.string)
(JD.field "startDate" decodeDate)
(JD.field "endDate" decodeDate)
(JD.field "comment" JD.string)
)
)
}
fetchUsers : Cmd Msg
fetchUsers =
Utils.getWithCredentials
@ -301,6 +383,13 @@ routeParser =
-}
init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg )
init _ url key =
let
( startDatePicker, startDatePickerCmd ) =
DatePicker.init
( endDatePicker, endDatePickerCmd ) =
DatePicker.init
in
( { route = Nothing
, url = url
, key = key
@ -310,14 +399,25 @@ init _ url key =
, password = ""
, role = Nothing
, users = RemoteData.NotAsked
, tripDestination = ""
, tripStartDate = Nothing
, tripEndDate = Nothing
, tripComment = ""
, trips = RemoteData.NotAsked
, startDatePicker = startDatePicker
, endDatePicker = endDatePicker
, adminTab = Users
, loginTab = LoginForm
, loginError = Nothing
, logoutError = Nothing
, signUpError = Nothing
, deleteUserError = Nothing
, createTripError = Nothing
}
, Cmd.none
, Cmd.batch
[ Cmd.map UpdateTripStartDate startDatePickerCmd
, Cmd.map UpdateTripEndDate endDatePickerCmd
]
)
@ -359,12 +459,59 @@ update msg model =
in
( { model | role = maybeRole }, Cmd.none )
UpdateTripDestination x ->
( { model | tripDestination = x }, Cmd.none )
UpdateTripStartDate dpMsg ->
let
( newDatePicker, dateEvent ) =
DatePicker.update DatePicker.defaultSettings dpMsg model.startDatePicker
newDate =
case dateEvent of
DatePicker.Picked changedDate ->
Just changedDate
_ ->
model.tripStartDate
in
( { model
| tripStartDate = newDate
, startDatePicker = newDatePicker
}
, Cmd.none
)
UpdateTripEndDate dpMsg ->
let
( newDatePicker, dateEvent ) =
DatePicker.update DatePicker.defaultSettings dpMsg model.endDatePicker
newDate =
case dateEvent of
DatePicker.Picked changedDate ->
Just changedDate
_ ->
model.tripEndDate
in
( { model
| tripEndDate = newDate
, endDatePicker = newDatePicker
}
, Cmd.none
)
UpdateTripComment x ->
( { model | tripComment = x }, Cmd.none )
ClearErrors ->
( { model
| loginError = Nothing
, logoutError = Nothing
, signUpError = Nothing
, deleteUserError = Nothing
, createTripError = Nothing
}
, Cmd.none
)
@ -400,27 +547,18 @@ update msg model =
( { model
| url = url
, route = route
, trips = RemoteData.Loading
}
, Cmd.none
, fetchTrips
)
Just ManagerHome ->
case model.session of
Nothing ->
( { model
| url = url
, route = route
}
, Cmd.none
)
Just session ->
( { model
| url = url
, route = route
}
, Cmd.none
)
( { model
| url = url
, route = route
}
, Cmd.none
)
Just AdminHome ->
( { model
@ -439,14 +577,14 @@ update msg model =
, Cmd.none
)
-- GET /all-usernames
-- GET /accounts
AttemptGetUsers ->
( { model | users = RemoteData.Loading }, fetchUsers )
GotUsers xs ->
( { model | users = xs }, Cmd.none )
-- DELETE /user/:username
-- DELETE /accounts
AttemptDeleteUser username ->
( model, deleteUser username )
@ -460,7 +598,47 @@ update msg model =
, sleepAndClearErrors
)
-- /create-account
-- POST /trips
AttemptCreateTrip startDate endDate ->
( model
, case model.session of
Nothing ->
Cmd.none
Just session ->
createTrip
{ username = session.username
, destination = model.tripDestination
, startDate = startDate
, endDate = endDate
, comment = model.tripComment
}
)
CreatedTrip result ->
case result of
Ok _ ->
( { model
| tripDestination = ""
, tripStartDate = Nothing
, tripEndDate = Nothing
, tripComment = ""
}
, fetchTrips
)
Err e ->
( { model
| createTripError = Just e
, tripDestination = ""
, tripStartDate = Nothing
, tripEndDate = Nothing
, tripComment = ""
}
, sleepAndClearErrors
)
-- POST /accounts
AttemptSignUp ->
( model
, signUp
@ -482,7 +660,11 @@ update msg model =
, sleepAndClearErrors
)
-- /login
-- GET /trips
GotTrips xs ->
( { model | trips = xs }, Cmd.none )
-- POST /login
AttemptLogin ->
( model, login model.username model.password )
@ -498,7 +680,7 @@ update msg model =
, sleepAndClearErrors
)
-- / logout
-- GET /logout
AttemptLogout ->
( model, logout )

25
client/src/UI.elm
View file

@ -1,5 +1,7 @@
module UI exposing (..)
import Date
import DatePicker exposing (defaultSettings)
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
@ -284,3 +286,26 @@ absentData { handleFetch } =
}
]
]
datePicker :
{ mDate : Maybe Date.Date
, prompt : String
, prefix : String
, picker : DatePicker.DatePicker
, onUpdate : DatePicker.Msg -> State.Msg
}
-> Html State.Msg
datePicker { mDate, prompt, prefix, picker, onUpdate } =
let
settings =
{ defaultSettings
| placeholder = prompt
, inputClassList =
[ ( "text-center", True )
, ( "py-2", True )
]
}
in
div [ [ "w-1/2", "py-4", "mx-auto" ] |> Tailwind.use |> class ]
[ DatePicker.view mDate settings picker |> Html.map onUpdate ]

113
client/src/User.elm
View file

@ -1,9 +1,12 @@
module User exposing (render)
import Common
import Date
import DatePicker
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Maybe.Extra
import Maybe.Extra as ME
import RemoteData
import State
import Tailwind
@ -11,6 +14,100 @@ import UI
import Utils
createTrip : State.Model -> Html State.Msg
createTrip model =
div []
[ UI.header 3 "Plan Upcoming Trip"
, UI.textField
{ pholder = "Where are you going?"
, inputId = "destination"
, handleInput = State.UpdateTripDestination
, inputValue = model.tripDestination
}
, div [ [ "flex" ] |> Tailwind.use |> class ]
[ UI.datePicker
{ mDate = model.tripStartDate
, prompt = "Set departure date"
, prefix = "Departure: "
, picker = model.startDatePicker
, onUpdate = State.UpdateTripStartDate
}
, UI.datePicker
{ mDate = model.tripEndDate
, prompt = "Set return date"
, prefix = "Return: "
, picker = model.endDatePicker
, onUpdate = State.UpdateTripEndDate
}
]
, UI.textField
{ pholder = "Comments?"
, inputId = "comment"
, handleInput = State.UpdateTripComment
, inputValue = model.tripComment
}
, UI.baseButton
{ enabled =
List.all
identity
[ String.length model.tripDestination > 0
, String.length model.tripComment > 0
, ME.isJust model.tripStartDate
, ME.isJust model.tripEndDate
]
, extraClasses = [ "my-4" ]
, handleClick =
case ( model.tripStartDate, model.tripEndDate ) of
( Nothing, _ ) ->
State.DoNothing
( _, Nothing ) ->
State.DoNothing
( Just startDate, Just endDate ) ->
State.AttemptCreateTrip startDate endDate
, label = "Schedule trip"
}
]
trips : State.Model -> Html msg
trips model =
div []
[ UI.header 3 "Upcoming Trips"
, case model.trips of
RemoteData.NotAsked ->
UI.paragraph "Somehow we've reached the user home page without requesting your trips data. Please report this to our engineering team at bugs@tripplaner.tld"
RemoteData.Loading ->
UI.paragraph "Loading your trips..."
RemoteData.Failure e ->
UI.paragraph ("Error: " ++ Utils.explainHttpError e)
RemoteData.Success xs ->
ul []
(xs
|> List.map
(\trip ->
li
[ [ "py-2" ]
|> Tailwind.use
|> class
]
[ text
(Date.toIsoString trip.startDate
++ " - "
++ Date.toIsoString trip.endDate
++ " -> "
++ trip.destination
)
]
)
)
]
render : State.Model -> Html State.Msg
render model =
div
@ -23,17 +120,11 @@ render model =
)
]
[ UI.header 2 ("Welcome, " ++ model.username ++ "!")
, UI.simpleButton
, createTrip model
, trips model
, UI.textButton
{ label = "Logout"
, handleClick = State.AttemptLogout
}
, case model.logoutError of
Nothing ->
text ""
Just e ->
UI.errorBanner
{ title = "Error logging out"
, body = Utils.explainHttpError e
}
, Common.allErrors model
]

40
src/Types.hs
View file

@ -10,6 +10,7 @@ import Data.Aeson
import Utils
import Data.Text
import Data.Typeable
import Data.String.Conversions (cs)
import Database.SQLite.Simple
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.FromField
@ -20,6 +21,8 @@ import Servant.API
import System.Envy (FromEnv, fromEnv, env)
import Crypto.Random.Types (MonadRandom)
import qualified Data.Time.Calendar as Calendar
import qualified Data.Time.Format as TF
import qualified Crypto.KDF.BCrypt as BC
import qualified Data.Time.Clock as Clock
import qualified Data.ByteString.Char8 as B
@ -192,19 +195,6 @@ instance ToField Comment where
instance FromField Comment where
fromField = forNewtype Comment
-- TODO(wpcarro): Replace this with a different type.
newtype Date = Date Text
deriving (Eq, Show, Generic)
instance ToJSON Date
instance FromJSON Date
instance ToField Date where
toField (Date x) = SQLText x
instance FromField Date where
fromField = forNewtype Date
newtype Destination = Destination Text
deriving (Eq, Show, Generic)
@ -217,11 +207,20 @@ instance ToField Destination where
instance FromField Destination where
fromField = forNewtype Destination
newtype Year = Year Integer deriving (Eq, Show)
newtype Month = Month Integer deriving (Eq, Show)
newtype Day = Day Integer deriving (Eq, Show)
data Date = Date
{ dateYear :: Year
, dateMonth :: Month
, dateDay :: Day
} deriving (Eq, Show)
data Trip = Trip
{ tripUsername :: Username
, tripDestination :: Destination
, tripStartDate :: Date
, tripEndDate :: Date
, tripStartDate :: Calendar.Day
, tripEndDate :: Calendar.Day
, tripComment :: Comment
} deriving (Eq, Show, Generic)
@ -238,10 +237,10 @@ instance FromRow Trip where
data TripPK = TripPK
{ tripPKUsername :: Username
, tripPKDestination :: Destination
, tripPKStartDate :: Date
, tripPKStartDate :: Clock.UTCTime
} deriving (Eq, Show, Generic)
tripPKFields :: TripPK -> (Username, Destination, Date)
tripPKFields :: TripPK -> (Username, Destination, Clock.UTCTime)
tripPKFields (TripPK{..})
= (tripPKUsername, tripPKDestination, tripPKStartDate)
@ -253,7 +252,8 @@ instance FromJSON TripPK where
pure TripPK{..}
-- | Return the tuple representation of a Trip record for SQL.
tripFields :: Trip -> (Username, Destination, Date, Date, Comment)
tripFields :: Trip
-> (Username, Destination, Calendar.Day, Calendar.Day, Comment)
tripFields (Trip{..})
= ( tripUsername
, tripDestination
@ -436,8 +436,8 @@ instance FromRow PendingAccount where
data UpdateTripRequest = UpdateTripRequest
{ updateTripRequestTripPK :: TripPK
, updateTripRequestDestination :: Maybe Destination
, updateTripRequestStartDate :: Maybe Date
, updateTripRequestEndDate :: Maybe Date
, updateTripRequestStartDate :: Maybe Calendar.Day
, updateTripRequestEndDate :: Maybe Calendar.Day
, updateTripRequestComment :: Maybe Comment
} deriving (Eq, Show)