Various improvements, esp final page

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

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

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

static/img/haskell-logo.svg

+<?xml version="1.0" encoding="UTF-8"?>
+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="17cm" height="12cm" viewBox="0 0 170 120" version="1.1">
+<defs>
+<clipPath id="clip1">
+  <path d="M 0 120 L 170 120 L 170 0 L 0 0 L 0 120 Z M 0 120 "/>
+</clipPath>
+</defs>
+<g id="surface0">
+<g clip-path="url(#clip1)" clip-rule="nonzero">
+<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 0 120 L 40 60 L 0 0 L 30 0 L 70 60 L 30 120 L 0 120 Z M 0 120 "/>
+<path style=" stroke:none;fill-rule: nonzero; fill: rgb(60%,60%,60%); fill-opacity: 1;" d="M 40 120 L 80 60 L 40 0 L 70 0 L 150 120 L 120 120 L 95 82.5 L 70 120 L 40 120 Z M 40 120 "/>
+<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 136.666667 85 L 123.333333 65 L 170 65 L 170 85 L 136.666667 85 Z M 136.666667 85 "/>
+<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 116.666667 55 L 103.333333 35 L 170 35 L 170 55 L 116.666667 55 Z M 116.666667 55 "/>
+</g>
+</g>
+</svg>
\ No newline at end of file

templates/book.hamlet

-<h1>Book an appointment
+<h1>Book your appointment
 
-<form role=form method=post action=@{BookR} enctype=#{enctype}>
+<form .form-horizontal role=form method=post action=@{BookR} enctype=#{enctype}>
   ^{whenWhere}
   ^{bookWidget}
-  <button type=submit .btn .btn-primary>Book it

templates/default-layout.hamlet

@@ -8,10 +8,10 @@
           #{name}
 
 $maybe pic <- appProviderAvatar (appSettings master)
-  <div .container>
+  <div #avatar .container>
     <div .row>
-      <div .col-md-12 style="margin: -60px 0 1ex 0;">
-        <img .img-circle width=100 height=100 src=#{pic} style="float:right">
+      <div .col-md-12>
+        <img .img-circle width=100 height=100 src=#{pic}>
 
 <div .container>
   $maybe msg <- mmsg

templates/default-layout.lucius

@@ -2,6 +2,16 @@ body {
     font-family: #{fontFamily};
 }
 
+#avatar .row {
+    margin-bottom: 40px;
+}
+#avatar img {
+    float: right;
+    position: absolute;
+    top: -65px;
+    right: 10px;
+}
+
 h1 {
     font-size: 28px;
     margin: 0 0 1ex 0;

templates/final.hamlet

+<h1>Appointment confirmation
+
+<p .alert.alert-success>
+  <b>Thanks #{bookName},
+  your appointment is on my calendar.
+
+<p>
+  You should receive a meeting invitation at your email address.
+
 <p>
-  Thanks #{bookName}, your appointment details are below. You should
-  also receive a meeting invitation at your email
-  address, #
-  <b>#{bookEmail}#
-  . Please click the “Yes” link in that message to confirm.
+  <b>
+    Please click the “Yes” link in that email to confirm.
 
 <p>
-  Should you need to cancel, please click the “No” link and reply to the
-  message.
+  Should you need to cancel, please click the “No” link in the
+  confirmation email, and then reply to the message.
+
+<div .form-horizontal>
 
-^{whenWhere}
+  ^{whenWhere}
 
-<div .form-group>
-  <label>Subject
+  <div .form-group>
+    <label .control-label .#{b3Class labelSize}>Email
+    <div .#{b3Class inputSize}>
+      <p .form-control-static>
+        #{bookEmail}
+
+  <div .form-group>
+    <label .control-label .#{b3Class labelSize}>Subject
+    <div .#{b3Class inputSize}>
       <p .form-control-static>
         #{bookSubject}
 
-$maybe ct <- bookContact
+  $maybe ct <- bookContact
     <div .form-group>
-    <label>Contact information
+      <label .control-label .#{b3Class labelSize}>Contact
+      <div .#{b3Class inputSize}>
         <p .form-control-static>
           #{ct}
+
+<p>
+  <a .btn.btn-warning href=@{ClearR}>
+    Public computer? Clear this session

templates/homepage.hamlet

 <h1>
-  Choose an appointment
+  Find time to meet
   <a ##{idReset} href=@{ClearR} :isNothing qOpt:style="display:none">
     <sup .text-danger title="Reset to default options">
       <span .glyphicon.glyphicon-remove style="font-size:70%">
 
+$maybe b <- bOpt
+  <p>
+    Welcome back, #{BF.bookName b}.
+    <a href=@{ClearR}>(Not you?)
+
+
 <form method=post action=@{HomeR} enctype=#{enctype}>
   ^{queryWidget}
   <div ##{idAvail} style="display:none">

templates/timezone.hamlet

 <input type=hidden name=#{name} value=#{currentTz}>
 
 $if isDefaultTz
-  <p #showDefaultTz>
+  <p ##{idShowDefaultTz}>
     in time zone: 
-    <span #textTz>
+    <span ##{idTextTz}>
       <span .glyphicon.glyphicon-globe style="position:relative; top:2px;">
-      #{concatMap tzChars currentTz}
+      #{prettyTz' currentTz}
 
-<div #selectTz :isDefaultTz:style="display:none">
+<div ##{idSelectTz} :isDefaultTz:style="display:none">
   <p>
     in time zone:
 

templates/timezone.julius

 $(function() {
-    $("#textTz").click(function(){
-        $("#showDefaultTz").hide();
-        $("#selectTz").show();
+    $("##{rawJS idTextTz}").click(function(){
+        $("##{rawJS idShowDefaultTz}").hide();
+        $("##{rawJS idSelectTz}").show();
         $("##{rawJS idReset}").show();
     });
 })

templates/timezone.lucius

-#textTz {
+##{idTextTz} {
     cursor: pointer;
     color: #000;
 }

templates/when-where.hamlet

 <div .form-group>
-  <label>When
+  <label .control-label .#{b3Class labelSize}>When
+  <div .#{b3Class inputSize}>
     <p .form-control-static>
       #{QF.showDate slotLocal} #{QF.showTime queryTimeFmt slotLocal}
-    (#{toPathPiece queryTzLabel})
+      (#{QF.prettyTz queryTzLabel})
       $maybe oz <- inOtherZone
         <br>
+        <span .text-muted>
           #{QF.showDate oz} #{QF.showTime queryTimeFmt oz}
-      (#{toPathPiece appDefaultTimeZone})
+          (#{QF.prettyTz appDefaultTimeZone})
 
 <div .form-group>
-  <label>Where
+  <label .control-label .#{b3Class labelSize}>Where
+  <div .#{b3Class inputSize}>
     <p .form-control-static>
       #{locDescr queryLocation}