From 3fba4846f8c2a91f1c261c2f615b2a0c62aca5cc Mon Sep 17 00:00:00 2001 From: Christopher League Date: Wed, 6 Jun 2018 17:19:33 -0400 Subject: [PATCH] Various improvements, esp final page --- src/BookingForm.hs | 56 +++++++++++++++++++++++++-------- src/Handlers.hs | 10 +++--- src/QueryForm.hs | 18 +++++++---- static/img/haskell-logo.svg | 16 ++++++++++ templates/book.hamlet | 5 ++- templates/default-layout.hamlet | 6 ++-- templates/default-layout.lucius | 10 ++++++ templates/final.hamlet | 52 ++++++++++++++++++++---------- templates/homepage.hamlet | 8 ++++- templates/timezone.hamlet | 8 ++--- templates/timezone.julius | 6 ++-- templates/timezone.lucius | 2 +- templates/when-where.hamlet | 25 ++++++++------- 13 files changed, 157 insertions(+), 65 deletions(-) create mode 100644 static/img/haskell-logo.svg diff --git a/src/BookingForm.hs b/src/BookingForm.hs index a8bb77a..eb91c7a 100644 --- a/src/BookingForm.hs +++ b/src/BookingForm.hs @@ -14,7 +14,11 @@ module BookingForm , bookingMForm , eventFromBooking , toSession + , fromSessionMaybe , fromSession + , b3Class + , inputSize + , labelSize ) where import Calendar @@ -39,8 +43,8 @@ toSession Booking {..} = do setSession "subject" bookSubject forM_ bookContact $ setSession "contact" -fromSession' :: MonadHandler m => MaybeT m Booking -fromSession' = do +fromSessionMaybe :: MonadHandler m => MaybeT m Booking +fromSessionMaybe = do bookName <- MaybeT $ lookupSession "name" bookEmail <- MaybeT $ lookupSession "email" bookSubject <- MaybeT $ lookupSession "subject" @@ -48,20 +52,46 @@ fromSession' = do return Booking {..} fromSession :: Handler Booking -fromSession = runMaybeT fromSession' >>= maybe QF.noSessionError return +fromSession = runMaybeT fromSessionMaybe >>= maybe QF.noSessionError return -bfs :: Text -> FieldSettings site -bfs = B3.bfs . asText +bfs :: Text -> String -> FieldSettings site +bfs label help = + (B3.bfs label) {fsTooltip = Just (fromString help)} -bookingAForm :: AForm Handler Booking -bookingAForm = - Booking <$> areq textField (bfs "Name") Nothing <*> - areq emailField (bfs "Email") Nothing <*> - areq textField (bfs "Subject") Nothing <*> - aopt textField (bfs "Contact") Nothing +bookingAForm :: Maybe Booking -> AForm Handler Booking +bookingAForm bOpt = + Booking <$> areq textField name (bookName <$> bOpt) <*> + areq emailField email (bookEmail <$> bOpt) <*> + areq textField subject (bookSubject <$> bOpt) <*> + aopt textField contact (bookContact <$> bOpt) <* + B3.bootstrapSubmit ("Submit" :: B3.BootstrapSubmit Text) + where + name = bfs "*Name" "Who are you?" + email = bfs "*Email" "You must use a valid email address" + subject = bfs "*Subject" "What course are you in? What do you want to talk about?" + contact = bfs "Contact" "For online meetings, how do I reach you?" + +horizOffset :: B3.BootstrapGridOptions +horizOffset = B3.ColMd 0 + +labelSize :: B3.BootstrapGridOptions +labelSize = B3.ColMd 1 -bookingMForm :: Html -> MForm Handler (FormResult Booking, Widget) -bookingMForm = B3.renderBootstrap3 B3.BootstrapBasicForm bookingAForm +inputSize :: B3.BootstrapGridOptions +inputSize = B3.ColMd 4 + +b3Class :: B3.BootstrapGridOptions -> Text +b3Class g = + case g of + B3.ColXs n -> "col-xs-" <> tshow n + B3.ColSm n -> "col-sm-" <> tshow n + B3.ColMd n -> "col-md-" <> tshow n + B3.ColLg n -> "col-lg-" <> tshow n + +bookingMForm :: Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget) +bookingMForm = B3.renderBootstrap3 horiz . bookingAForm + where + horiz = B3.BootstrapHorizontalForm horizOffset labelSize horizOffset inputSize eventFromBooking :: Booking -> QF.QueryForm -> QF.TimeSlot -> SimpleEventUTC eventFromBooking Booking {..} QF.QueryForm {..} slot = SimpleEvent {..} diff --git a/src/Handlers.hs b/src/Handlers.hs index c32b056..d052c0e 100644 --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -25,6 +25,7 @@ module Handlers ) where import qualified BookingForm as BF +import BookingForm (b3Class, inputSize, labelSize) import Calendar import Control.Monad.Trans.Maybe import Data.FileEmbed (embedFile) @@ -50,6 +51,7 @@ getHomeR -- Produce form for query and display parameters: appointment length, -- 12/24-hour time, time zone, location. qOpt <- runMaybeT QF.fromSession + bOpt <- runMaybeT BF.fromSessionMaybe (idReset, idSpinner, idAvail, idAlert) <- newIdent4 (queryWidget, enctype) <- generateFormPost $ QF.queryForm idReset qOpt defaultLayout $(widgetFile "homepage") @@ -87,11 +89,12 @@ postHomeR = do QF.toSessionWithSlot q slot redirect BookR --- | Show for to collect client's personal data. +-- | Show form to collect client's personal data. getBookR :: Handler Html getBookR = do (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere - (bookWidget, enctype) <- generateFormPost BF.bookingMForm + bOpt <- runMaybeT BF.fromSessionMaybe + (bookWidget, enctype) <- generateFormPost (BF.bookingMForm bOpt) defaultLayout $(widgetFile "book") showWhenWhere :: Handler (QF.QueryForm, QF.TimeSlot, Widget) @@ -107,7 +110,7 @@ showWhenWhere = do postBookR :: Handler Html postBookR = do (q, slot) <- QF.fromSessionWithSlot - b <- formSuccess =<< runFormPost BF.bookingMForm + b <- formSuccess =<< runFormPost (BF.bookingMForm Nothing) BF.toSession b let event = BF.eventFromBooking b q slot matches e = @@ -127,7 +130,6 @@ getFinalR :: Handler Html getFinalR = do (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere BF.Booking{..} <- BF.fromSession - setMessage "You are booked!" defaultLayout $(widgetFile "final") getClearR :: Handler Html diff --git a/src/QueryForm.hs b/src/QueryForm.hs index 199816b..01bb468 100644 --- a/src/QueryForm.hs +++ b/src/QueryForm.hs @@ -36,6 +36,7 @@ module QueryForm , noSessionError , showDate , showTime + , prettyTz ) where import Control.Monad.Trans.Maybe @@ -209,10 +210,15 @@ locationChoiceField = Field {..} locs <- appLocations . appSettings <$> getYesod $(widgetFile "query-locations") -tzChars :: Char -> Text -tzChars '_' = " " -tzChars '/' = " » " -tzChars c = singleton c +prettyTz' :: Text -> Text +prettyTz' = concatMap tzChars + where + tzChars '_' = " " + tzChars '/' = " » " + tzChars c = singleton c + +prettyTz :: TZLabelW -> Text +prettyTz = prettyTz' . toPathPiece zonesByContinent :: Map Text [(Text, Text)] zonesByContinent = @@ -222,7 +228,7 @@ zonesByContinent = allZones = [minBound..maxBound] splitTz :: TZLabelW -> (Text, (Text, Text)) - splitTz tz = (cont, (txt, concatMap tzChars (drop 1 city))) + splitTz tz = (cont, (txt, prettyTz' (drop 1 city))) where (cont, city) = break (== '/') txt txt = toPathPiece tz @@ -239,7 +245,7 @@ tzSelectorField idReset = Field {..} fieldParse _ _ = return $ Left $ SomeMessage $ MsgInvalidEntry "Timezone" fieldView _ name attrs val _ = do AppSettings{appDefaultTimeZone} <- appSettings <$> getYesod - (idTextTz, idSelectTz) <- newIdent2 + (idShowDefaultTz, idTextTz, idSelectTz) <- newIdent3 let currentTz = toPathPiece $ either (const appDefaultTimeZone) id val isDefaultTz = currentTz == toPathPiece appDefaultTimeZone cityAttrs = [(asText "class", "tzsel " <> qControl)] diff --git a/static/img/haskell-logo.svg b/static/img/haskell-logo.svg new file mode 100644 index 0000000..bb8e59b --- /dev/null +++ b/static/img/haskell-logo.svg @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/templates/book.hamlet b/templates/book.hamlet index 95dd4be..4033661 100644 --- a/templates/book.hamlet +++ b/templates/book.hamlet @@ -1,6 +1,5 @@ -

Book an appointment +

Book your appointment -
+ ^{whenWhere} ^{bookWidget} -