diff --git a/config/routes b/config/routes index dfe22c40b3622c0061dae7b3d737cc15ff437f3f..ac61fd3f61966f3bb2d22a23a2cd0357056cd848 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 0000000000000000000000000000000000000000..9632775d1d82b82f354907281be51b6969f6ed15 --- /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 b8a7251d8fab7c131ce260ab4b15b0fdf6b7c7c1..40506f5715f868a687c6f351ee71f931c5988265 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 85c0b60b6ab9e637397130682a9acfcc0e3aa23f..7df970807cd93bf168706920033595508256fcb4 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 -