Handlers.hs 4.96 KB
Newer Older
Christopher League's avatar
Christopher League committed
1
{-# LANGUAGE NamedFieldPuns #-}
2
{-# LANGUAGE OverloadedStrings #-}
Christopher League's avatar
Christopher League committed
3
4
5
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
6
{-# LANGUAGE NoImplicitPrelude #-}
7

8
9
10
11
12
-- |
-- Module: Handlers
-- Description: TODO
--
-- TODO
13
module Handlers
Christopher League's avatar
Christopher League committed
14
15
16
17
18
19
20
21
22
  ( getFaviconR,
    getRobotsR,
    getHomeR,
    getAvailR,
    postHomeR,
    getBookR,
    postBookR,
    getFinalR,
    getClearR,
23
24
    getVersionR,
  )
Christopher League's avatar
Christopher League committed
25
where
26

Christopher League's avatar
Christopher League committed
27
28
29
30
31
32
import BookingForm (b3Class, inputSize, labelSize)
import qualified BookingForm as BF
import Calendar
import Control.Monad.Trans.Maybe
import Data.FileEmbed (embedFile)
import qualified Data.SortedList as SL
33
import Data.Time.Clock (addUTCTime)
Christopher League's avatar
Christopher League committed
34
35
36
37
38
39
import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
import qualified FreshCache as FC
import Import
import qualified QueryForm as QF
import Text.Hamlet (shamletFile)
import Text.Julius (RawJS (..))
40
41
42
43

-- | Home page, which shows query settings. Also has an AJAX facility
-- to get the available slots and show them as buttons.
getHomeR :: Handler Html
Christopher League's avatar
Christopher League committed
44
getHomeR =
45
  -- Start refresh of calendar, but don't wait for result.
Christopher League's avatar
Christopher League committed
46
47
48
49
50
51
52
53
54
55
  do
    App {appCalendarCache} <- getYesod
    void $ async $ FC.readCache appCalendarCache
    -- 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")
56
57
58
59
60

-- | Ensure a successful form submission, or else throw a 400.
formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
formSuccess ((formResult, _), _) =
  case formResult of
Christopher League's avatar
Christopher League committed
61
    FormMissing -> invalidArgs ["Missing form data!"]
62
63
64
65
66
67
68
    FormFailure errors -> invalidArgs errors
    FormSuccess result -> return result

-- | AJAX facility to retrieve available times matching the query
-- parameters, and show them as buttons.
getAvailR :: Handler Html
getAvailR = do
69
  QF.QueryForm {..} <- formSuccess =<< runFormGet (QF.queryForm "" Nothing)
70
  App {appSettings = AppSettings {..}, appCalendarCache} <- getYesod
71
  earliest <- addUTCTime appLeadTime <$> liftIO getCurrentTime
72
  daysWithSlots <-
Christopher League's avatar
Christopher League committed
73
74
75
76
77
78
    groupByDay
      . SL.map (applyTz (tzByLabel queryTzLabel))
      . SL.dropWhile ((< earliest) . seStart)
      . partitionSlots (headMay appApptLengthsMinutes) queryApptLength
      . SL.filter (summaryMatches (locSearch queryLocation))
      <$> FC.readCache appCalendarCache
79
80
81
82
  return $(shamletFile "templates/avail.hamlet")

postHomeR :: Handler Html
postHomeR = do
83
  q@QF.QueryForm {..} <- formSuccess =<< runFormPost (QF.queryForm "" Nothing)
84
85
86
87
  slot <- runInputPost QF.timeInput
  QF.toSessionWithSlot q slot
  redirect BookR

88
-- | Show form to collect client's personal data.
89
90
getBookR :: Handler Html
getBookR = do
91
  (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
92
93
  bOpt <- runMaybeT BF.fromSessionMaybe
  (bookWidget, enctype) <- generateFormPost (BF.bookingMForm bOpt)
94
95
96
97
  defaultLayout $(widgetFile "book")

showWhenWhere :: Handler (QF.QueryForm, QF.TimeSlot, Widget)
showWhenWhere = do
98
  AppSettings {appDefaultTimeZone} <- appSettings <$> getYesod
99
100
  (q@QF.QueryForm {..}, s@QF.TimeSlot {..}) <- QF.fromSessionWithSlot
  let inOtherZone =
101
102
        if queryTzLabel == appDefaultTimeZone
          then Nothing
Christopher League's avatar
Christopher League committed
103
104
105
106
          else
            Just
              $ utcToLocalTimeTZ (tzByLabel appDefaultTimeZone)
              $ localTimeToUTCTZ (tzByLabel queryTzLabel) slotLocal
107
  return (q, s, $(widgetFile "when-where"))
108
109
110
111

postBookR :: Handler Html
postBookR = do
  (q, slot) <- QF.fromSessionWithSlot
112
  b <- formSuccess =<< runFormPost (BF.bookingMForm Nothing)
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
  BF.toSession b
  let event = BF.eventFromBooking b q slot
      matches e =
        summaryMatches (locSearch (QF.queryLocation q)) e && event `isWithin` e
  App {..} <- getYesod
  r <- find matches . SL.fromSortedList <$> FC.readCache appCalendarCache
  case r of
    Nothing -> do
      setMessage "Selected time is no longer available! Please try again."
      redirect HomeR
    Just _ -> do
      addEvent appCalendarCxt (appBusyCalendarId appSettings) event
      FC.invalidateCache appCalendarCache
      redirect FinalR

getFinalR :: Handler Html
getFinalR = do
130
  (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
131
  BF.Booking {..} <- BF.fromSession
132
  defaultLayout $(widgetFile "final")
133

Christopher League's avatar
Christopher League committed
134
135
136
getClearR :: Handler Html
getClearR = clearSession >> redirect HomeR

137
138
139
140
141
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
getFaviconR = do
  cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
Christopher League's avatar
Christopher League committed
142
143
144
  return
    $ TypedContent "image/x-icon"
    $ toContent $(embedFile "config/favicon.ico")
145
146
147
148

getRobotsR :: Handler TypedContent
getRobotsR =
  return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")
Christopher League's avatar
Christopher League committed
149

150
151
152
getVersionR :: Handler TypedContent
getVersionR =
  redirect $ StaticR version_txt