Home.hs 3.33 KB
Newer Older
1
{-# LANGUAGE FlexibleContexts      #-}
2
{-# LANGUAGE LambdaCase            #-}
3
{-# LANGUAGE MultiParamTypeClasses #-}
4 5 6 7 8 9 10
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

11 12
module Handler.Home where

13 14 15 16
import qualified Calendar            as Cal
import Control.Monad.Logger (logInfoN)
import           Data.Time.LocalTime (LocalTime)
import Yesod.Form.Bootstrap3
17
import           Import
18 19 20
import qualified QueryForm           as QF
import qualified BookingForm as BF
import           Text.Julius         (RawJS (..))
21 22

getHomeR :: Handler Html
23
getHomeR = do
24
  App {..} <- getYesod
25
  -- Start refresh of calendar, but don't wait for result.
26
  void $ async $ appGetCalendar Nothing
27
  (widget, enctype) <- generateFormPost QF.queryForm
28
  (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
29 30 31 32 33 34 35 36 37 38 39 40
  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
41

42
getAvailR :: Handler Html
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65
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}
|]
66

67 68 69 70 71 72 73
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
74 75
  defaultLayout
    [whamlet|
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
<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"