diff --git a/src/BookingForm.hs b/src/BookingForm.hs index a8bb77a3b005565ded04cf3768bf0de6100223e3..eb91c7acfc9c0c70c15f230a6c5e2922cd86c43e 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 c32b0569b00b2dd0a96a4bafe4681adedcfa111c..d052c0e60572ba91de0755c3aefe2e41bb8d575a 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 199816b4dc6b27e1b43769e0f7984a85f815fb1e..01bb468e3d8624be8d5ff62df6c1dc8100bd7df3 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 0000000000000000000000000000000000000000..bb8e59b2450a03db0451c70b42e3e18eb959214f --- /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 95dd4be743e0575a1c25a3705ef2e803f4e70f82..4033661d2495996bc48e7417af7a15f615669617 100644 --- a/templates/book.hamlet +++ b/templates/book.hamlet @@ -1,6 +1,5 @@ -

Book an appointment +

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