Handlers.hs 5.3 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
  ) where

import qualified BookingForm               as BF
28
import BookingForm (b3Class, inputSize, labelSize)
29
30
31
32
import           Calendar
import           Control.Monad.Trans.Maybe
import           Data.FileEmbed            (embedFile)
import qualified Data.SortedList           as SL
33
import Data.Time.Clock (getCurrentTime, addUTCTime)
34
import qualified Network.Wai
Christopher League's avatar
Christopher League committed
35
import           Development.GitRev
36
import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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
54
  bOpt <- runMaybeT BF.fromSessionMaybe
55
56
  (idReset, idSpinner, idAvail, idAlert) <- newIdent4
  (queryWidget, enctype) <- generateFormPost $ QF.queryForm idReset qOpt
57
58
59
60
61
62
63
64
65
66
67
68
69
70
  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
71
  QF.QueryForm {..} <- formSuccess =<< runFormGet (QF.queryForm "" Nothing)
72
  App { appSettings = AppSettings {..}
73
74
      , appCalendarCache
      } <- getYesod
75
  earliest <- addUTCTime appLeadTime <$> liftIO getCurrentTime
76
77
78
  daysWithSlots <-
    groupByDay .
    SL.map (applyTz (tzByLabel queryTzLabel)) .
79
    SL.dropWhile ((< earliest) . seStart) .
80
81
82
83
84
85
86
    partitionSlots (headMay appApptLengthsMinutes) queryApptLength .
    SL.filter (summaryMatches (locSearch queryLocation)) <$>
    FC.readCache appCalendarCache
  return $(shamletFile "templates/avail.hamlet")

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

92
-- | Show form to collect client's personal data.
93
94
getBookR :: Handler Html
getBookR = do
95
  (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
96
97
  bOpt <- runMaybeT BF.fromSessionMaybe
  (bookWidget, enctype) <- generateFormPost (BF.bookingMForm bOpt)
98
99
100
101
102
103
104
105
106
107
108
  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"))
109
110
111
112

postBookR :: Handler Html
postBookR = do
  (q, slot) <- QF.fromSessionWithSlot
113
  b <- formSuccess =<< runFormPost (BF.bookingMForm Nothing)
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
  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
131
132
133
  (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
  BF.Booking{..} <- BF.fromSession
  defaultLayout $(widgetFile "final")
134

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

138
139
140
141
142
143
144
145
146
147
148
-- 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
149
150

getVersionR :: Handler Text
151
152
153
154
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 ""