Handlers.hs 4.23 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}

{-|
Module: Handlers
Description: TODO

TODO
-}
module Handlers
  ( getFaviconR
  , getRobotsR
  , getHomeR
  , getAvailR
  , postHomeR
  , getBookR
  , postBookR
  , getFinalR
Christopher League's avatar
Christopher League committed
23
  , getClearR
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
  ) where

import qualified BookingForm               as BF
import           Calendar
import           Control.Monad.Trans.Maybe
import           Data.FileEmbed            (embedFile)
import qualified Data.SortedList           as SL
import qualified FreshCache                as FC
import           Import
import qualified QueryForm                 as QF
import           Text.Hamlet               (shamletFile)
import           Text.Julius               (RawJS (..))

-- | Home page, which shows query settings. Also has an AJAX facility
-- to get the available slots and show them as buttons.
getHomeR :: Handler Html
getHomeR
  -- Start refresh of calendar, but don't wait for result.
 = 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
  (queryWidget, enctype) <- generateFormPost $ QF.queryForm qOpt
  (idSpinner, idAvail, idAlert) <- newIdent3
  defaultLayout $(widgetFile "homepage")

-- | Ensure a successful form submission, or else throw a 400.
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

-- | AJAX facility to retrieve available times matching the query
-- parameters, and show them as buttons.
getAvailR :: Handler Html
getAvailR = do
  QF.QueryForm {..} <- formSuccess =<< runFormGet (QF.queryForm Nothing)
  App { appSettings = AppSettings {appApptLengthsMinutes, appLookaheadWeeks}
      , appCalendarCache
      } <- getYesod
  daysWithSlots <-
    groupByDay .
    SL.map (applyTz (tzByLabel queryTzLabel)) .
    partitionSlots (headMay appApptLengthsMinutes) queryApptLength .
    SL.filter (summaryMatches (locSearch queryLocation)) <$>
    FC.readCache appCalendarCache
  return $(shamletFile "templates/avail.hamlet")

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

-- | Show for to collect client's personal data.
getBookR :: Handler Html
getBookR = do
  (QF.QueryForm {..}, QF.TimeSlot {..}) <- QF.fromSessionWithSlot
  (bookWidget, enctype) <- generateFormPost BF.bookingMForm
  defaultLayout $(widgetFile "confirm")

postBookR :: Handler Html
postBookR = do
  (q, slot) <- QF.fromSessionWithSlot
  b <- formSuccess =<< runFormPost BF.bookingMForm
  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
  (q, QF.TimeSlot {..}) <- QF.fromSessionWithSlot
  b <- BF.fromSession
  defaultLayout
    [whamlet|
            <p>#{tshow q}
            <p>#{tshow slotLocal}
            <p>#{tshow b}
            |]

Christopher League's avatar
Christopher League committed
120
121
122
getClearR :: Handler Html
getClearR = clearSession >> redirect HomeR

123
124
125
126
127
128
129
130
131
132
133
-- 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
  return $
    TypedContent "image/x-icon" $ toContent $(embedFile "config/favicon.ico")

getRobotsR :: Handler TypedContent
getRobotsR =
  return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")