Handlers.hs 4.14 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
23
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
120
121
122
123
124
125
126
127
128
129
{-# 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
  ) 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}
            |]

-- 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")