From 96de7e74e49758c3e4d318002f3e4987cd621128 Mon Sep 17 00:00:00 2001 From: Christopher League Date: Thu, 31 May 2018 22:45:40 -0400 Subject: [PATCH] Progress in QueryForm/BookingForm interaction --- config/routes | 4 +- src/BookingForm.hs | 49 ++++++++++++ src/Foundation.hs | 8 -- src/Handler/Home.hs | 118 ++++++++++++++++----------- src/QueryForm.hs | 70 ++++++++++++---- src/Settings.hs | 4 + templates/default-layout.hamlet | 21 ++--- templates/homepage.hamlet | 138 +++----------------------------- templates/homepage.julius | 50 +++++------- templates/homepage.lucius | 40 +++++++-- templates/query-form.julius | 8 +- templates/step1.hamlet | 13 --- templates/step1.julius | 20 ----- templates/step1.lucius | 37 --------- 14 files changed, 249 insertions(+), 331 deletions(-) create mode 100644 src/BookingForm.hs delete mode 100644 templates/step1.hamlet delete mode 100644 templates/step1.julius delete mode 100644 templates/step1.lucius diff --git a/config/routes b/config/routes index dfe22c4..ac61fd3 100644 --- a/config/routes +++ b/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 diff --git a/src/BookingForm.hs b/src/BookingForm.hs new file mode 100644 index 0000000..9632775 --- /dev/null +++ b/src/BookingForm.hs @@ -0,0 +1,49 @@ +{-# 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| +

#{locDescr val} + + |] + +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 diff --git a/src/Foundation.hs b/src/Foundation.hs index b8a7251..40506f5 100644 --- a/src/Foundation.hs +++ b/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 = diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 85c0b60..7df9708 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -1,5 +1,5 @@ {-# 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 -

#{showD firstSlot} -

- $forall eachSlot <- eachDay -