Handlers.hs 5.04 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
Christopher League's avatar
Christopher League committed
24
  , getVersionR
25
26
27
28
29
30
31
  ) where

import qualified BookingForm               as BF
import           Calendar
import           Control.Monad.Trans.Maybe
import           Data.FileEmbed            (embedFile)
import qualified Data.SortedList           as SL
32
import qualified Network.Wai
Christopher League's avatar
Christopher League committed
33
import           Development.GitRev
34
import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
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
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
90
  (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
91
  (bookWidget, enctype) <- generateFormPost BF.bookingMForm
92
93
94
95
96
97
98
99
100
101
102
  defaultLayout $(widgetFile "book")

showWhenWhere :: Handler (QF.QueryForm, QF.TimeSlot, Widget)
showWhenWhere = do
  AppSettings{appDefaultTimeZone} <- appSettings <$> getYesod
  (q@QF.QueryForm {..}, s@QF.TimeSlot {..}) <- QF.fromSessionWithSlot
  let inOtherZone =
        if queryTzLabel == appDefaultTimeZone then Nothing
        else Just $ utcToLocalTimeTZ (tzByLabel appDefaultTimeZone)
             $ localTimeToUTCTZ (tzByLabel queryTzLabel) slotLocal
  return (q, s, $(widgetFile "when-where"))
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124

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
125
126
127
128
  (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
  BF.Booking{..} <- BF.fromSession
  setMessage "You are booked!"
  defaultLayout $(widgetFile "final")
129

Christopher League's avatar
Christopher League committed
130
131
132
getClearR :: Handler Html
getClearR = clearSession >> redirect HomeR

133
134
135
136
137
138
139
140
141
142
143
-- 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")
Christopher League's avatar
Christopher League committed
144
145

getVersionR :: Handler Text
146
147
148
149
getVersionR = do
  req <- reqWaiRequest <$> getRequest
  let hs = foldMap (\(h,v) -> tshow h <> ": " <> tshow v <> "\n") $ Network.Wai.requestHeaders req
  return $ hs <> "\n" <> $(gitHash) <> if $(gitDirty) then "+" else ""