Progress in QueryForm/BookingForm interaction

config/routes

@@ -6,6 +6,6 @@
 /favicon.ico     FaviconR      GET
 /robots.txt      RobotsR       GET
 
-/                HomeR         GET
-/confirm         ConfirmR           POST
+/                HomeR         GET  POST
 /available       AvailR        GET
+/confirm         ConfirmR           POST

src/BookingForm.hs

+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+{-|
+Module: BookingForm
+Description: TODO
+
+TODO
+-}
+module BookingForm
+  ( Booking(..)
+  , bookingForm
+  ) where
+
+import Import
+import QueryForm
+import Data.Time.LocalTime (LocalTime)
+import qualified Yesod.Form.Bootstrap3 as B3
+
+data Booking =
+  Booking
+  { bookName       :: Text
+  , bookEmail      :: Text
+  , bookContact    :: Maybe Text
+  , bookSubject    :: Text
+  } deriving (Show)
+
+bfs = B3.bfs . asText
+
+locationShowField :: Field Handler Location
+locationShowField = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldParse = parseLocationField
+    fieldView i _ attrs (Right val) _ =
+      [whamlet|
+              <p .form-control-static>#{locDescr val}
+              <input type=hidden name=#{i}>
+              |]
+
+bookingForm :: QueryForm -> AForm Handler Booking
+bookingForm QueryForm{..} =
+  Booking
+  <$> areq textField  (bfs "Name") Nothing
+  <*> areq emailField (bfs "Email") Nothing
+  <*> aopt textField  (bfs "Contact") Nothing
+  <*> areq textField  (bfs "Subject") Nothing

src/Foundation.hs

@@ -109,14 +109,6 @@ instance Yesod App where
   defaultLayout widget = do
     master <- getYesod
     mmsg <- getMessage
-    mcurrentRoute <- getCurrentRoute
-        -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-    (title, parents) <- breadcrumbs
-        -- We break up the default layout into two components:
-        -- default-layout is the contents of the body tag, and
-        -- default-layout-wrapper is the entire page. Since the final
-        -- value passed to hamletToRepHtml cannot be a widget, this allows
-        -- you to use normal widget features in default-layout.
     pc <-
       widgetToPageContent $ do
         let fontFamily =

src/Handler/Home.hs

 {-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -10,11 +10,14 @@
 
 module Handler.Home where
 
-import qualified Calendar         as Cal
+import qualified Calendar            as Cal
+import Control.Monad.Logger (logInfoN)
+import           Data.Time.LocalTime (LocalTime)
+import Yesod.Form.Bootstrap3
 import           Import
-import           Text.Julius      (RawJS (..))
-import Data.Time.LocalTime (LocalTime)
-import qualified QueryForm as QF
+import qualified QueryForm           as QF
+import qualified BookingForm as BF
+import           Text.Julius         (RawJS (..))
 
 getHomeR :: Handler Html
 getHomeR = do
@@ -23,48 +26,73 @@ getHomeR = do
   void $ async $ appGetCalendar Nothing
   (widget, enctype) <- generateFormPost QF.queryForm
   (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
-  defaultLayout $(widgetFile "step1")
+  defaultLayout $(widgetFile "homepage")
+
+formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
+formSuccess ((formResult,_),_) =
+  case formResult of
+    FormMissing -> invalidArgs ["Missing form data!"]
+    FormFailure errors -> invalidArgs errors
+    FormSuccess result -> return result
+
+showD = QF.showDate . Cal.seStart
+showT fmt = QF.showTime fmt . Cal.seStart
+slotVal = tshow . Cal.seStart
 
 getAvailR :: Handler Html
-getAvailR =
-  fst . fst <$> runFormGet QF.queryForm >>= \case
-  FormMissing -> invalidArgs ["missing"]
-  FormFailure errs -> invalidArgs errs
-  FormSuccess QF.QueryForm{..} -> do
-    App {appSettings = AppSettings {..}, ..} <- getYesod
-    let tz = tzByLabel queryTzLabel
-        showT = QF.showTime queryTimeFmt . Cal.seStart
-        showD = QF.showDate . Cal.seStart
-        slotVal = tshow . Cal.seStart
-    avail <-
-      Cal.groupByDay .
-      map (Cal.applyTz tz) .
-      Cal.partitionSlots queryApptLength .
-      filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
-      appGetCalendar Nothing
-    withUrlRenderer
-      [hamlet|
-             $if null avail
-               No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
-             $forall eachDay <- avail
-               $maybe firstSlot <- headMay eachDay
-                 <h4>#{showD firstSlot}
-                 <p .slot-choices>
-                   $forall eachSlot <- eachDay
-                     <button type=submit name=slot value=#{slotVal eachSlot} .btn.btn-default.btn-small>#{showT eachSlot}
-               |]
+getAvailR = do
+  QF.QueryForm{..} <- formSuccess =<< runFormGet QF.queryForm
+  App {appSettings = AppSettings {..}, ..} <- getYesod
+  let tz = tzByLabel queryTzLabel
+  avail <-
+    Cal.groupByDay .
+    map (Cal.applyTz tz) .
+    Cal.partitionSlots queryApptLength .
+    filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
+    appGetCalendar Nothing
+  withUrlRenderer
+    [hamlet|
+$if null avail
+  No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
+$forall eachDay <- avail
+  $maybe firstSlot <- headMay eachDay
+    <h4>#{showD firstSlot}
+    <p .slot-choices>
+      $forall eachSlot <- eachDay
+        <button type=submit name=slot value=#{slotVal eachSlot}
+                .btn.btn-default.btn-small>
+          #{showT queryTimeFmt eachSlot}
+|]
 
-postConfirmR :: Handler Html
-postConfirmR = do
-  ((qr, _), _) <- runFormPost QF.queryForm
-  let zz :: Maybe LocalTime
-      zz = case qr of
-             FormSuccess QF.QueryForm{QF.querySlot = Just txt} -> readMay txt
+postHomeR :: Handler Html
+postHomeR = do
+  q@QF.QueryForm {..} <- formSuccess =<< runFormPost QF.queryForm
+  slot <- maybe (invalidArgs ["Missing time slot"]) (return . QF.slotLocal) querySlot
+  (widget, enctype) <- generateFormPost
+    $ renderBootstrap3 BootstrapBasicForm
+    $ BF.bookingForm q
   defaultLayout
     [whamlet|
-            <p>OK?
-            <p>
-              #{tshow qr}
-            <p>
-              #{tshow zz}
-            |]
+<p>OK?
+<p>#{tshow q}
+<form role=form method=post action=@{ConfirmR} enctype=#{enctype}>
+  <input type=hidden name=#{QF.idApptLength} value=#{toPathPiece queryApptLength}>
+  <input type=hidden name=#{QF.idTimeFmt}    value=#{toPathPiece queryTimeFmt}>
+  <input type=hidden name=#{QF.idTzLabel}    value=#{toPathPiece queryTzLabel}>
+  <input type=hidden name=#{QF.idLocation}   value=#{toPathPiece queryLocation}>
+  <input type=hidden name=#{QF.idSlot}       value=#{toPathPiece querySlot}>
+  <div .form-group>
+    <label>When
+    <p .form-control-static>
+      #{QF.showDate slot} #{QF.showTime queryTimeFmt slot}
+      (#{toPathPiece queryTzLabel})
+  <div .form-group>
+    <label>Where
+    <p .form-control-static>
+      #{locDescr queryLocation}
+  ^{widget}
+  <button type=submit .btn .btn-primary>Book it
+|]
+
+postConfirmR :: Handler Html
+postConfirmR = error "postConfirmR"

src/QueryForm.hs

 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
@@ -16,9 +17,17 @@ location, appointment length, time format, and time zone.
 module QueryForm
   ( QueryForm(..)
   , TimeFmt(..)
+  , Slot(..)
   , queryForm
   , showDate
   , showTime
+  , getLocationById
+  , parseLocationField
+  , idApptLength
+  , idTimeFmt
+  , idTzLabel
+  , idLocation
+  , idSlot
   ) where
 
 import qualified Data.Time.Format    as TF
@@ -41,14 +50,33 @@ instance PathPiece TimeFmt where
 instance Default TimeFmt where
   def = Time12h
 
+newtype Slot = Slot { slotLocal :: LocalTime }
+  deriving Show
+
+instance PathPiece Slot where
+  toPathPiece = tshow . slotLocal
+  fromPathPiece t = Slot <$> readMay t
+
 data QueryForm = QueryForm
   { queryApptLength :: Int
   , queryTimeFmt    :: TimeFmt
   , queryTzLabel    :: TZLabelW
   , queryLocation   :: Location
-  , querySlot       :: Maybe Text -- TBD
+  , querySlot       :: Maybe Slot
   } deriving (Show)
 
+idApptLength :: Text
+idTimeFmt    :: Text
+idTzLabel    :: Text
+idLocation   :: Text
+idSlot       :: Text
+
+idApptLength = "len"
+idTimeFmt    = "fmt"
+idTzLabel    = "tz"
+idLocation   = "loc"
+idSlot       = "slot"
+
 apptLengthOptions :: Handler (OptionList Int)
 apptLengthOptions = do
   lengths <- appApptLengthsMinutes . appSettings <$> getYesod
@@ -79,16 +107,23 @@ timeFmtOptions =
         ]
     }
 
-locationField :: Field Handler Location
-locationField = Field {..}
+getLocationById :: Text -> Handler (Maybe Location)
+getLocationById i = do
+  find ((== i) . locId) . appLocations . appSettings <$> getYesod
+
+parseLocationField :: [Text] -> [FileInfo] -> Handler (Either (SomeMessage App) (Maybe Location))
+parseLocationField [] _ =
+  return $ Left $ SomeMessage $ MsgInputNotFound "location"
+parseLocationField (txt:_) _ =
+  getLocationById txt >>= return . \case
+  Nothing  -> Left $ SomeMessage $ MsgInvalidEntry txt
+  Just loc -> Right $ Just loc
+
+locationChoiceField :: Field Handler Location
+locationChoiceField = Field {..}
   where
-    fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location"
-    fieldParse (txt:_) _ = do
-      locs <- appLocations . appSettings <$> getYesod
-      return $
-        case find ((== txt) . locId) locs of
-          Nothing  -> Left $ SomeMessage $ MsgInvalidEntry txt
-          Just loc -> Right $ Just loc
+    fieldEnctype = UrlEncoded
+    fieldParse = parseLocationField
     fieldView i _ attrs val _ = do
       locs <- appLocations . appSettings <$> getYesod
       [whamlet|
@@ -101,7 +136,7 @@ locationField = Field {..}
                              *{attrs}>
                         #{locDescr loc}
               |]
-    fieldEnctype = UrlEncoded
+
 
 queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
 queryForm extra = do
@@ -111,14 +146,15 @@ queryForm extra = do
   (lenRes, lenView) <-
     mreq
       (selectField apptLengthOptions)
-      (qs "len")
+      (qs idApptLength)
       (headMay appApptLengthsMinutes)
-  (fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
-  (locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
-  (slotRes, _) <- mopt textField (qs "slot") Nothing
+  (fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs idTimeFmt) (Just def)
+  (locRes, locView) <- mreq locationChoiceField (qs idLocation) (headMay appLocations)
+  (slotRes, _) <- mopt textField (qs idSlot) Nothing
+  (tzRes, _) <- mreq hiddenField (qs idTzLabel) (Just appDefaultTimeZone)
   let q =
-        QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*>
-        slotRes
+        QueryForm <$> lenRes <*> fmtRes <*> tzRes <*> locRes <*>
+        ((>>= fromPathPiece) <$> slotRes)
       widget = $(widgetFile "query-form")
   return (q, widget)
 

src/Settings.hs

@@ -53,6 +53,10 @@ data Location = Location
   , locDescr  :: Text -- ^ Description of location
   } deriving (Show, Eq)
 
+instance PathPiece Location where
+  toPathPiece = locId
+  fromPathPiece _ = Nothing -- Warning: not a round-trip!
+
 -- | Construct locations, adding IDs like "locA", "locB".
 makeLocs :: [(Text, Text)] -> [Location]
 makeLocs = zipWith mk ['A' ..]

templates/default-layout.hamlet

 
-<!-- Page Contents -->
-
 <div .container>
-    $if not $ Just HomeR == mcurrentRoute
-        <ul .breadcrumb>
-            $forall bc <- parents
-                <li>
-                    <a href="@{fst bc}">#{snd bc}
-
-            <li .active>#{title}
-
-    $maybe msg <- mmsg
-      <div .alert.alert-info #message>#{msg}
-
+  $maybe msg <- mmsg
+    <div .alert.alert-info #message>#{msg}
 
 <div .container>
-    <div .row>
-        <div .col-md-12>
-            ^{widget}
+  <div .row>
+    <div .col-md-12>
+      ^{widget}

templates/homepage.hamlet

-<div .masthead>
-    <div .container>
-        <div .row>
-            <h1 .header>
-                Yesod—a modern framework for blazing fast websites
-            <h2>
-                Fast, stable & spiced with great community
-            <a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg>
-                Read the Book
+<h2>Book an appointment
 
-<div .container>
-    <!-- Starting
-        ================================================== -->
-    <div .bs-docs-section>
-        <div .row>
-            <div .col-lg-12>
-                <div .page-header>
-                    <h1 #start>Starting
+<form enctype=#{enctype} method=POST action=@{HomeR}>
+  ^{widget}
 
-                    <p>
-                        Now that you have a working project you should use the
-                        <a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more.
-                    <p>
-                        You can also use this scaffolded site to explore some concepts, and best practices.
+  <div ##{idAvail} style="display:none">
 
-                    <ul .list-group>
+<p ##{idSpinner} style="font-size:150%">
+  <span .glyphicon.glyphicon-off.fast-right-spinner>
 
-                        <li .list-group-item>
-                            This page was generated by the <tt>#{handlerName}</tt> handler in
-                            <tt>Handler/Home.hs</tt>.
-
-                        <li .list-group-item>
-                            The <tt>#{handlerName}</tt> handler is set to generate your
-                            site's home screen in Routes file
-                            <tt>config/routes
-
-                        <li .list-group-item>
-                            The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
-                            most of them are brought together by the <tt>defaultLayout</tt> function which #
-                            is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. #
-                            All the files for templates and wigdets are in <tt>templates</tt>.
-
-                        <li .list-group-item>
-                            A Widget's Html, Css and Javascript are separated in three files with the
-                            <tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions.
-
-                        <li .list-group-item ##{aDomId}>
-                            If you had javascript enabled then you wouldn't be seeing this.
-
-    <hr>
-
-    <!-- Forms
-        ================================================== -->
-    <div .bs-docs-section>
-        <div .row>
-            <div .col-lg-12>
-                <div .page-header>
-                    <h1 #forms>Forms
-
-                    <p>
-                        This is an example of a form. Read the
-                        <a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
-                        on the yesod book to learn more about them.
-
-        <div .row>
-            <div .col-lg-6>
-                <div .bs-callout bs-callout-info well>
-                    <form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}>
-                        ^{formWidget}
-
-                        <button .btn.btn-primary type="submit">
-                            Upload it!
-
-
-            <div .col-lg-4.col-lg-offset-1>
-                <div .bs-callout.bs-callout-info.upload-response>
-
-                    $maybe (FileForm info con) <- submission
-                        Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
-
-                    $nothing
-                        File upload result will be here...
-
-
-    <hr>
-
-    <!-- JSON
-        ================================================== -->
-    <div .bs-docs-section>
-        <div .row>
-            <div .col-lg-12>
-                <div .page-header>
-                    <h1 #json>JSON
-
-                    <p>
-                        Yesod has JSON support baked-in.
-                        The form below makes an AJAX request with Javascript,
-                        then updates the page with your submission.
-                        (see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>,
-                        and <tt>Handler/Home.hs</tt> for the implementation).
-
-        <div .row>
-            <div .col-lg-6>
-                <div .bs-callout.bs-callout-info.well>
-                    <form .form-horizontal ##{commentFormId}>
-                        <div .field>
-                            <textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea>
-
-                        <button .btn.btn-primary type=submit>
-                           Create comment
-
-           <div .col-lg-4.col-lg-offset-1>
-               <div .bs-callout.bs-callout-info>
-                   <small>
-                       Your comments will appear here. You can also open the
-                       console log to see the raw response from the server.
-                   <ul ##{commentListId}>
-
-    <hr>
-
-    <!-- Testing
-       ================================================== -->
-    <div .bs-docs-section>
-       <div .row>
-           <div .col-lg-12>
-               <div .page-header>
-                   <h1 #test>Testing
-
-                   <p>
-                       And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a #
-                       test suite that performs tests on this page.
-                   <p>
-                       You can run your tests by doing: <code>stack test</code>
+<div ##{idAlert} .alert.alert-danger style="display:none" role=alert>
+  <p>
+    <b>Oops

templates/homepage.julius

-document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
+// -*- js -*-
 
-$(function() {
-  $("##{rawJS commentFormId}").submit(function(event) {
-    event.preventDefault();
-
-    var message = $("##{rawJS commentTextareaId}").val();
-    // (Browsers that enforce the "required" attribute on the textarea won't see this alert)
-    if (!message) {
-      alert("Please fill out the comment form first.");
-      return;
-    }
-
-    // Make an AJAX request to the server to create a new comment
+function sendQuery() {
+    $("##{rawJS idSpinner}").show();
+    $("##{rawJS idAvail}").hide();
+    var url = "@{AvailR}?" + gatherQueryParams();
     $.ajax({
-      url: '@{CommentR}',
-      type: 'POST',
-      contentType: "application/json",
-      data: JSON.stringify({
-        message: message,
-      }),
-      success: function (data) {
-        var newNode = $("<li></li>");
-        newNode.text(data.message);
-        console.log(data);
-        $("##{rawJS commentListId}").append(newNode);
-      },
-      error: function (data) {
-        console.log("Error creating comment: " + data);
-      },
-    });
-
-  });
-});
+        url: url,
+        success: function(data) {
+            $("##{rawJS idAvail}").html(data);
+            $("##{rawJS idAvail}").show();
+        },
+        error: function(data) {
+            $("##{rawJS idAlert}").html(data.statusText).show();
+        },
+        complete: function() {
+            $("##{rawJS idSpinner}").hide();
+        },
+    })
+}

templates/homepage.lucius

-h2##{aDomId} {
-    color: #990
+/* step1.lucius -*- css -*- */
+
+
+/* Glyphicons spinner from https://bootsnipp.com/snippets/djeAk */
+
+.fast-right-spinner {
+  -webkit-animation: glyphicon-spin-r 1s infinite linear;
+  animation: glyphicon-spin-r 1s infinite linear;
 }
 
-li {
-    line-height: 2em;
-    font-size: 16px
+.slot-choices button {
+    margin: 0 8px 10px 0;
 }
 
-##{commentTextareaId} {
-    width: 400px;
-    height: 100px;
+@-webkit-keyframes glyphicon-spin-r {
+    0% {
+        -webkit-transform: rotate(0deg);
+        transform: rotate(0deg);
+    }
+
+    100% {
+        -webkit-transform: rotate(359deg);
+        transform: rotate(359deg);
+    }
+}
+
+@keyframes glyphicon-spin-r {
+    0% {
+        -webkit-transform: rotate(0deg);
+        transform: rotate(0deg);
+    }
+
+    100% {
+        -webkit-transform: rotate(359deg);
+        transform: rotate(359deg);
+    }
 }

templates/query-form.julius

@@ -5,9 +5,9 @@ $(function(){
 function gatherQueryParams() {
     return $.param({
         _hasdata: 1,
-        tz: $("#tz").val(),
-        len: $("#len").val(),
-        fmt: $("#fmt").val(),
-        loc: $("input[name=loc]:checked").val(),
+        #{rawJS idTzLabel}:    $("##{rawJS idTzLabel}").val(),
+        #{rawJS idApptLength}: $("##{rawJS idApptLength}").val(),
+        #{rawJS idTimeFmt}:    $("##{rawJS idTimeFmt}").val(),
+        #{rawJS idLocation}:   $("input[name=#{rawJS idLocation}]:checked").val(),
     });
 }