diff options
author | William Carroll <wpcarro@gmail.com> | 2020-08-01T22·04+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-08-01T22·04+0100 |
commit | 249e3113ffbcda047bd9461f01aaa64aa2dd94f1 (patch) | |
tree | 6f3edd19086b88a60e48fa66a74cbc501e776b35 | |
parent | 54eb29eae0398dd19f5fdaed278f29453b0b7e44 (diff) |
Support creating Trips from the frontend
*sigh* ... spent way too much time encoding/decoding date types... I need my database, server, client, and JSON need to agree on types. TL;DR: - Add CSS for elm/datepicker library - Create Common.allErrors to display UI errors - Prefer Data.Time.Calendar.Day instead of newtype Date wrapper around Text
-rw-r--r-- | client/elm.json | 2 | ||||
-rw-r--r-- | client/index.css | 139 | ||||
-rw-r--r-- | client/src/Admin.elm | 20 | ||||
-rw-r--r-- | client/src/Common.elm | 27 | ||||
-rw-r--r-- | client/src/Login.elm | 30 | ||||
-rw-r--r-- | client/src/Manager.elm | 11 | ||||
-rw-r--r-- | client/src/State.elm | 242 | ||||
-rw-r--r-- | client/src/UI.elm | 25 | ||||
-rw-r--r-- | client/src/User.elm | 113 | ||||
-rw-r--r-- | src/Types.hs | 40 |
10 files changed, 534 insertions, 115 deletions
diff --git a/client/elm.json b/client/elm.json index 76664b62b8ed..c4095e118e24 100644 --- a/client/elm.json +++ b/client/elm.json @@ -6,6 +6,7 @@ "elm-version": "0.19.1", "dependencies": { "direct": { + "CurrySoftware/elm-datepicker": "4.0.0", "elm/browser": "1.0.2", "elm/core": "1.0.5", "elm/html": "1.0.0", @@ -19,6 +20,7 @@ "elm-community/list-extra": "8.2.3", "elm-community/maybe-extra": "5.2.0", "elm-community/random-extra": "3.1.0", + "justinmimbs/date": "3.2.1", "krisajenkins/remotedata": "6.0.1", "ryannhg/date-format": "2.3.0" }, diff --git a/client/index.css b/client/index.css index b5c61c956711..52114e0e9fb0 100644 --- a/client/index.css +++ b/client/index.css @@ -1,3 +1,142 @@ @tailwind base; @tailwind components; @tailwind utilities; + +.elm-datepicker--container { + position: relative; +} + +.elm-datepicker--input:focus { + outline: 0; +} + +.elm-datepicker--picker { + position: absolute; + border: 1px solid #CCC; + z-index: 10; + background-color: white; +} + +.elm-datepicker--picker-header, +.elm-datepicker--weekdays { + background: #F2F2F2; +} + +.elm-datepicker--picker-header { + display: flex; + align-items: center; +} + +.elm-datepicker--prev-container, +.elm-datepicker--next-container { + flex: 0 1 auto; + cursor: pointer; +} + +.elm-datepicker--month-container { + flex: 1 1 auto; + padding: 0.5em; + display: flex; + flex-direction: column; +} + +.elm-datepicker--month, +.elm-datepicker--year { + flex: 1 1 auto; + cursor: default; + text-align: center; +} + +.elm-datepicker--year { + font-size: 0.6em; + font-weight: 700; +} + +.elm-datepicker--prev, +.elm-datepicker--next { + border: 6px solid transparent; + background-color: inherit; + display: block; + width: 0; + height: 0; + padding: 0 0.2em; +} + +.elm-datepicker--prev { + border-right-color: #AAA; +} + +.elm-datepicker--prev:hover { + border-right-color: #BBB; +} + +.elm-datepicker--next { + border-left-color: #AAA; +} + +.elm-datepicker--next:hover { + border-left-color: #BBB; +} + +.elm-datepicker--table { + border-spacing: 0; + border-collapse: collapse; + font-size: 0.8em; +} + +.elm-datepicker--table td { + width: 2em; + height: 2em; + text-align: center; +} + +.elm-datepicker--row { + border-top: 1px solid #F2F2F2; +} + +.elm-datepicker--dow { + border-bottom: 1px solid #CCC; + cursor: default; +} + +.elm-datepicker--day { + cursor: pointer; +} + +.elm-datepicker--day:hover { + background: #F2F2F2; +} + +.elm-datepicker--disabled { + cursor: default; + color: #DDD; +} + +.elm-datepicker--disabled:hover { + background: inherit; +} + +.elm-datepicker--picked { + color: white; + background: darkblue; +} + +.elm-datepicker--picked:hover { + background: darkblue; +} + +.elm-datepicker--today { + font-weight: bold; +} + +.elm-datepicker--other-month { + color: #AAA; +} + +.elm-datepicker--other-month.elm-datepicker--disabled { + color: #EEE; +} + +.elm-datepicker--other-month.elm-datepicker--picked { + color: white; +} diff --git a/client/src/Admin.elm b/client/src/Admin.elm index 3c0f221d93ed..e8e33bde617b 100644 --- a/client/src/Admin.elm +++ b/client/src/Admin.elm @@ -5,6 +5,7 @@ import Html.Attributes exposing (..) import Html.Events exposing (..) import RemoteData import State +import Common import Tailwind import UI import Utils @@ -78,22 +79,5 @@ render model = , case model.adminTab of State.Users -> allUsers model - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } - , case model.deleteUserError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error attempting to delete user" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] diff --git a/client/src/Common.elm b/client/src/Common.elm new file mode 100644 index 000000000000..a3106114d43a --- /dev/null +++ b/client/src/Common.elm @@ -0,0 +1,27 @@ +module Common exposing (..) + +import Html exposing (..) +import Maybe.Extra as ME +import State +import UI +import Utils + + +allErrors : State.Model -> Html State.Msg +allErrors model = + div [] + (State.allErrors + model + |> List.map + (\( mError, title ) -> + case mError of + Nothing -> + text "" + + Just err -> + UI.errorBanner + { title = title + , body = Utils.explainHttpError err + } + ) + ) diff --git a/client/src/Login.elm b/client/src/Login.elm index 60a45e7fca77..083c4705609d 100644 --- a/client/src/Login.elm +++ b/client/src/Login.elm @@ -1,5 +1,6 @@ module Login exposing (render) +import Common import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -137,24 +138,7 @@ login model = ] [ UI.header 3 "Welcome to Trip Planner" , loginForm model - , case model.loginError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging in" - , body = Utils.explainHttpError e - } - , case model.signUpError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error creating account" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] @@ -174,15 +158,7 @@ logout model = { label = "Logout" , handleClick = State.AttemptLogout } - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] diff --git a/client/src/Manager.elm b/client/src/Manager.elm index b7f36cfd46bb..7cf5dc3107c3 100644 --- a/client/src/Manager.elm +++ b/client/src/Manager.elm @@ -1,6 +1,7 @@ module Manager exposing (render) import Array +import Common import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -33,14 +34,6 @@ render model = { label = "Logout" , handleClick = State.AttemptLogout } - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] ] diff --git a/client/src/State.elm b/client/src/State.elm index e23580a05ebb..66b3e57f0c79 100644 --- a/client/src/State.elm +++ b/client/src/State.elm @@ -3,6 +3,8 @@ module State exposing (..) import Array exposing (Array) import Browser import Browser.Navigation as Nav +import Date +import DatePicker import Http import Json.Decode as JD import Json.Decode.Extra as JDE @@ -31,6 +33,10 @@ type Msg | UpdatePassword String | UpdateRole String | UpdateAdminTab AdminTab + | UpdateTripDestination String + | UpdateTripStartDate DatePicker.Msg + | UpdateTripEndDate DatePicker.Msg + | UpdateTripComment String | ClearErrors | ToggleLoginForm -- SPA @@ -42,12 +48,15 @@ type Msg | AttemptLogin | AttemptLogout | AttemptDeleteUser String + | AttemptCreateTrip Date.Date Date.Date -- Inbound network | GotUsers (WebData AllUsers) + | GotTrips (WebData (List Trip)) | GotSignUp (Result Http.Error Session) | GotLogin (Result Http.Error Session) | GotLogout (Result Http.Error String) | GotDeleteUser (Result Http.Error String) + | CreatedTrip (Result Http.Error ()) type Route @@ -85,13 +94,6 @@ type alias Review = } -type alias Reviews = - { hi : Maybe Review - , lo : Maybe Review - , all : List Review - } - - type AdminTab = Users @@ -101,6 +103,14 @@ type LoginTab | SignUpForm +type alias Trip = + { destination : String + , startDate : Date.Date + , endDate : Date.Date + , comment : String + } + + type alias Model = { route : Maybe Route , url : Url.Url @@ -111,15 +121,33 @@ type alias Model = , password : String , role : Maybe Role , users : WebData AllUsers + , startDatePicker : DatePicker.DatePicker + , endDatePicker : DatePicker.DatePicker + , tripDestination : String + , tripStartDate : Maybe Date.Date + , tripEndDate : Maybe Date.Date + , tripComment : String + , trips : WebData (List Trip) , adminTab : AdminTab , loginTab : LoginTab , loginError : Maybe Http.Error , logoutError : Maybe Http.Error , signUpError : Maybe Http.Error , deleteUserError : Maybe Http.Error + , createTripError : Maybe Http.Error } +allErrors : Model -> List ( Maybe Http.Error, String ) +allErrors model = + [ ( model.loginError, "Error attempting to authenticate" ) + , ( model.logoutError, "Error attempting to log out" ) + , ( model.signUpError, "Error attempting to create your account" ) + , ( model.deleteUserError, "Error attempting to delete a user" ) + , ( model.createTripError, "Error attempting to create a trip" ) + ] + + -------------------------------------------------------------------------------- -- Functions @@ -220,6 +248,31 @@ signUp { username, email, password } = } +createTrip : + { username : String + , destination : String + , startDate : Date.Date + , endDate : Date.Date + , comment : String + } + -> Cmd Msg +createTrip { username, destination, startDate, endDate, comment } = + Utils.postWithCredentials + { url = endpoint [ "trips" ] [] + , body = + Http.jsonBody + (JE.object + [ ( "username", JE.string username ) + , ( "destination", JE.string destination ) + , ( "startDate", encodeDate startDate ) + , ( "endDate", encodeDate endDate ) + , ( "comment", JE.string comment ) + ] + ) + , expect = Http.expectWhatever CreatedTrip + } + + deleteUser : String -> Cmd Msg deleteUser username = Utils.deleteWithCredentials @@ -239,6 +292,35 @@ decodeReview = (JD.field "timestamp" JD.string) +encodeDate : Date.Date -> JE.Value +encodeDate date = + date |> Date.toIsoString |> JE.string + + +decodeDate : JD.Decoder Date.Date +decodeDate = + JD.string |> JD.andThen (Date.fromIsoString >> JDE.fromResult) + + +fetchTrips : Cmd Msg +fetchTrips = + Utils.getWithCredentials + { url = endpoint [ "trips" ] [] + , expect = + Http.expectJson + (RemoteData.fromResult >> GotTrips) + (JD.list + (JD.map4 + Trip + (JD.field "destination" JD.string) + (JD.field "startDate" decodeDate) + (JD.field "endDate" decodeDate) + (JD.field "comment" JD.string) + ) + ) + } + + fetchUsers : Cmd Msg fetchUsers = Utils.getWithCredentials @@ -301,6 +383,13 @@ routeParser = -} init : () -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) init _ url key = + let + ( startDatePicker, startDatePickerCmd ) = + DatePicker.init + + ( endDatePicker, endDatePickerCmd ) = + DatePicker.init + in ( { route = Nothing , url = url , key = key @@ -310,14 +399,25 @@ init _ url key = , password = "" , role = Nothing , users = RemoteData.NotAsked + , tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + , trips = RemoteData.NotAsked + , startDatePicker = startDatePicker + , endDatePicker = endDatePicker , adminTab = Users , loginTab = LoginForm , loginError = Nothing , logoutError = Nothing , signUpError = Nothing , deleteUserError = Nothing + , createTripError = Nothing } - , Cmd.none + , Cmd.batch + [ Cmd.map UpdateTripStartDate startDatePickerCmd + , Cmd.map UpdateTripEndDate endDatePickerCmd + ] ) @@ -359,12 +459,59 @@ update msg model = in ( { model | role = maybeRole }, Cmd.none ) + UpdateTripDestination x -> + ( { model | tripDestination = x }, Cmd.none ) + + UpdateTripStartDate dpMsg -> + let + ( newDatePicker, dateEvent ) = + DatePicker.update DatePicker.defaultSettings dpMsg model.startDatePicker + + newDate = + case dateEvent of + DatePicker.Picked changedDate -> + Just changedDate + + _ -> + model.tripStartDate + in + ( { model + | tripStartDate = newDate + , startDatePicker = newDatePicker + } + , Cmd.none + ) + + UpdateTripEndDate dpMsg -> + let + ( newDatePicker, dateEvent ) = + DatePicker.update DatePicker.defaultSettings dpMsg model.endDatePicker + + newDate = + case dateEvent of + DatePicker.Picked changedDate -> + Just changedDate + + _ -> + model.tripEndDate + in + ( { model + | tripEndDate = newDate + , endDatePicker = newDatePicker + } + , Cmd.none + ) + + UpdateTripComment x -> + ( { model | tripComment = x }, Cmd.none ) + ClearErrors -> ( { model | loginError = Nothing , logoutError = Nothing , signUpError = Nothing , deleteUserError = Nothing + , createTripError = Nothing } , Cmd.none ) @@ -400,27 +547,18 @@ update msg model = ( { model | url = url , route = route + , trips = RemoteData.Loading } - , Cmd.none + , fetchTrips ) Just ManagerHome -> - case model.session of - Nothing -> - ( { model - | url = url - , route = route - } - , Cmd.none - ) - - Just session -> - ( { model - | url = url - , route = route - } - , Cmd.none - ) + ( { model + | url = url + , route = route + } + , Cmd.none + ) Just AdminHome -> ( { model @@ -439,14 +577,14 @@ update msg model = , Cmd.none ) - -- GET /all-usernames + -- GET /accounts AttemptGetUsers -> ( { model | users = RemoteData.Loading }, fetchUsers ) GotUsers xs -> ( { model | users = xs }, Cmd.none ) - -- DELETE /user/:username + -- DELETE /accounts AttemptDeleteUser username -> ( model, deleteUser username ) @@ -460,7 +598,47 @@ update msg model = , sleepAndClearErrors ) - -- /create-account + -- POST /trips + AttemptCreateTrip startDate endDate -> + ( model + , case model.session of + Nothing -> + Cmd.none + + Just session -> + createTrip + { username = session.username + , destination = model.tripDestination + , startDate = startDate + , endDate = endDate + , comment = model.tripComment + } + ) + + CreatedTrip result -> + case result of + Ok _ -> + ( { model + | tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + } + , fetchTrips + ) + + Err e -> + ( { model + | createTripError = Just e + , tripDestination = "" + , tripStartDate = Nothing + , tripEndDate = Nothing + , tripComment = "" + } + , sleepAndClearErrors + ) + + -- POST /accounts AttemptSignUp -> ( model , signUp @@ -482,7 +660,11 @@ update msg model = , sleepAndClearErrors ) - -- /login + -- GET /trips + GotTrips xs -> + ( { model | trips = xs }, Cmd.none ) + + -- POST /login AttemptLogin -> ( model, login model.username model.password ) @@ -498,7 +680,7 @@ update msg model = , sleepAndClearErrors ) - -- / logout + -- GET /logout AttemptLogout -> ( model, logout ) diff --git a/client/src/UI.elm b/client/src/UI.elm index 482c6ebe9dd8..1de137fcaf4f 100644 --- a/client/src/UI.elm +++ b/client/src/UI.elm @@ -1,5 +1,7 @@ module UI exposing (..) +import Date +import DatePicker exposing (defaultSettings) import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -284,3 +286,26 @@ absentData { handleFetch } = } ] ] + + +datePicker : + { mDate : Maybe Date.Date + , prompt : String + , prefix : String + , picker : DatePicker.DatePicker + , onUpdate : DatePicker.Msg -> State.Msg + } + -> Html State.Msg +datePicker { mDate, prompt, prefix, picker, onUpdate } = + let + settings = + { defaultSettings + | placeholder = prompt + , inputClassList = + [ ( "text-center", True ) + , ( "py-2", True ) + ] + } + in + div [ [ "w-1/2", "py-4", "mx-auto" ] |> Tailwind.use |> class ] + [ DatePicker.view mDate settings picker |> Html.map onUpdate ] diff --git a/client/src/User.elm b/client/src/User.elm index 7139d2028368..5216eeada03e 100644 --- a/client/src/User.elm +++ b/client/src/User.elm @@ -1,9 +1,12 @@ module User exposing (render) +import Common +import Date +import DatePicker import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import Maybe.Extra +import Maybe.Extra as ME import RemoteData import State import Tailwind @@ -11,6 +14,100 @@ import UI import Utils +createTrip : State.Model -> Html State.Msg +createTrip model = + div [] + [ UI.header 3 "Plan Upcoming Trip" + , UI.textField + { pholder = "Where are you going?" + , inputId = "destination" + , handleInput = State.UpdateTripDestination + , inputValue = model.tripDestination + } + , div [ [ "flex" ] |> Tailwind.use |> class ] + [ UI.datePicker + { mDate = model.tripStartDate + , prompt = "Set departure date" + , prefix = "Departure: " + , picker = model.startDatePicker + , onUpdate = State.UpdateTripStartDate + } + , UI.datePicker + { mDate = model.tripEndDate + , prompt = "Set return date" + , prefix = "Return: " + , picker = model.endDatePicker + , onUpdate = State.UpdateTripEndDate + } + ] + , UI.textField + { pholder = "Comments?" + , inputId = "comment" + , handleInput = State.UpdateTripComment + , inputValue = model.tripComment + } + , UI.baseButton + { enabled = + List.all + identity + [ String.length model.tripDestination > 0 + , String.length model.tripComment > 0 + , ME.isJust model.tripStartDate + , ME.isJust model.tripEndDate + ] + , extraClasses = [ "my-4" ] + , handleClick = + case ( model.tripStartDate, model.tripEndDate ) of + ( Nothing, _ ) -> + State.DoNothing + + ( _, Nothing ) -> + State.DoNothing + + ( Just startDate, Just endDate ) -> + State.AttemptCreateTrip startDate endDate + , label = "Schedule trip" + } + ] + + +trips : State.Model -> Html msg +trips model = + div [] + [ UI.header 3 "Upcoming Trips" + , case model.trips of + RemoteData.NotAsked -> + UI.paragraph "Somehow we've reached the user home page without requesting your trips data. Please report this to our engineering team at bugs@tripplaner.tld" + + RemoteData.Loading -> + UI.paragraph "Loading your trips..." + + RemoteData.Failure e -> + UI.paragraph ("Error: " ++ Utils.explainHttpError e) + + RemoteData.Success xs -> + ul [] + (xs + |> List.map + (\trip -> + li + [ [ "py-2" ] + |> Tailwind.use + |> class + ] + [ text + (Date.toIsoString trip.startDate + ++ " - " + ++ Date.toIsoString trip.endDate + ++ " -> " + ++ trip.destination + ) + ] + ) + ) + ] + + render : State.Model -> Html State.Msg render model = div @@ -23,17 +120,11 @@ render model = ) ] [ UI.header 2 ("Welcome, " ++ model.username ++ "!") - , UI.simpleButton + , createTrip model + , trips model + , UI.textButton { label = "Logout" , handleClick = State.AttemptLogout } - , case model.logoutError of - Nothing -> - text "" - - Just e -> - UI.errorBanner - { title = "Error logging out" - , body = Utils.explainHttpError e - } + , Common.allErrors model ] diff --git a/src/Types.hs b/src/Types.hs index 7afb29276d98..11422f8db90b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,6 +10,7 @@ import Data.Aeson import Utils import Data.Text import Data.Typeable +import Data.String.Conversions (cs) import Database.SQLite.Simple import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField @@ -20,6 +21,8 @@ import Servant.API import System.Envy (FromEnv, fromEnv, env) import Crypto.Random.Types (MonadRandom) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Format as TF import qualified Crypto.KDF.BCrypt as BC import qualified Data.Time.Clock as Clock import qualified Data.ByteString.Char8 as B @@ -192,19 +195,6 @@ instance ToField Comment where instance FromField Comment where fromField = forNewtype Comment --- TODO(wpcarro): Replace this with a different type. -newtype Date = Date Text - deriving (Eq, Show, Generic) - -instance ToJSON Date -instance FromJSON Date - -instance ToField Date where - toField (Date x) = SQLText x - -instance FromField Date where - fromField = forNewtype Date - newtype Destination = Destination Text deriving (Eq, Show, Generic) @@ -217,11 +207,20 @@ instance ToField Destination where instance FromField Destination where fromField = forNewtype Destination +newtype Year = Year Integer deriving (Eq, Show) +newtype Month = Month Integer deriving (Eq, Show) +newtype Day = Day Integer deriving (Eq, Show) +data Date = Date + { dateYear :: Year + , dateMonth :: Month + , dateDay :: Day + } deriving (Eq, Show) + data Trip = Trip { tripUsername :: Username , tripDestination :: Destination - , tripStartDate :: Date - , tripEndDate :: Date + , tripStartDate :: Calendar.Day + , tripEndDate :: Calendar.Day , tripComment :: Comment } deriving (Eq, Show, Generic) @@ -238,10 +237,10 @@ instance FromRow Trip where data TripPK = TripPK { tripPKUsername :: Username , tripPKDestination :: Destination - , tripPKStartDate :: Date + , tripPKStartDate :: Clock.UTCTime } deriving (Eq, Show, Generic) -tripPKFields :: TripPK -> (Username, Destination, Date) +tripPKFields :: TripPK -> (Username, Destination, Clock.UTCTime) tripPKFields (TripPK{..}) = (tripPKUsername, tripPKDestination, tripPKStartDate) @@ -253,7 +252,8 @@ instance FromJSON TripPK where pure TripPK{..} -- | Return the tuple representation of a Trip record for SQL. -tripFields :: Trip -> (Username, Destination, Date, Date, Comment) +tripFields :: Trip + -> (Username, Destination, Calendar.Day, Calendar.Day, Comment) tripFields (Trip{..}) = ( tripUsername , tripDestination @@ -436,8 +436,8 @@ instance FromRow PendingAccount where data UpdateTripRequest = UpdateTripRequest { updateTripRequestTripPK :: TripPK , updateTripRequestDestination :: Maybe Destination - , updateTripRequestStartDate :: Maybe Date - , updateTripRequestEndDate :: Maybe Date + , updateTripRequestStartDate :: Maybe Calendar.Day + , updateTripRequestEndDate :: Maybe Calendar.Day , updateTripRequestComment :: Maybe Comment } deriving (Eq, Show) |