Commit cea30e2e authored by Christopher League's avatar Christopher League 🖥

Remove header debugging in VersionR; run hfmt -w

parent 3fba4846
...@@ -55,8 +55,7 @@ fromSession :: Handler Booking ...@@ -55,8 +55,7 @@ fromSession :: Handler Booking
fromSession = runMaybeT fromSessionMaybe >>= maybe QF.noSessionError return fromSession = runMaybeT fromSessionMaybe >>= maybe QF.noSessionError return
bfs :: Text -> String -> FieldSettings site bfs :: Text -> String -> FieldSettings site
bfs label help = bfs label help = (B3.bfs label) {fsTooltip = Just (fromString help)}
(B3.bfs label) {fsTooltip = Just (fromString help)}
bookingAForm :: Maybe Booking -> AForm Handler Booking bookingAForm :: Maybe Booking -> AForm Handler Booking
bookingAForm bOpt = bookingAForm bOpt =
...@@ -66,9 +65,10 @@ bookingAForm bOpt = ...@@ -66,9 +65,10 @@ bookingAForm bOpt =
aopt textField contact (bookContact <$> bOpt) <* aopt textField contact (bookContact <$> bOpt) <*
B3.bootstrapSubmit ("Submit" :: B3.BootstrapSubmit Text) B3.bootstrapSubmit ("Submit" :: B3.BootstrapSubmit Text)
where where
name = bfs "*Name" "Who are you?" name = bfs "*Name" "Who are you?"
email = bfs "*Email" "You must use a valid email address" email = bfs "*Email" "You must use a valid email address"
subject = bfs "*Subject" "What course are you in? What do you want to talk about?" subject =
bfs "*Subject" "What course are you in? What do you want to talk about?"
contact = bfs "Contact" "For online meetings, how do I reach you?" contact = bfs "Contact" "For online meetings, how do I reach you?"
horizOffset :: B3.BootstrapGridOptions horizOffset :: B3.BootstrapGridOptions
...@@ -88,10 +88,12 @@ b3Class g = ...@@ -88,10 +88,12 @@ b3Class g =
B3.ColMd n -> "col-md-" <> tshow n B3.ColMd n -> "col-md-" <> tshow n
B3.ColLg n -> "col-lg-" <> tshow n B3.ColLg n -> "col-lg-" <> tshow n
bookingMForm :: Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget) bookingMForm ::
Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm = B3.renderBootstrap3 horiz . bookingAForm bookingMForm = B3.renderBootstrap3 horiz . bookingAForm
where where
horiz = B3.BootstrapHorizontalForm horizOffset labelSize horizOffset inputSize horiz =
B3.BootstrapHorizontalForm horizOffset labelSize horizOffset inputSize
eventFromBooking :: Booking -> QF.QueryForm -> QF.TimeSlot -> SimpleEventUTC eventFromBooking :: Booking -> QF.QueryForm -> QF.TimeSlot -> SimpleEventUTC
eventFromBooking Booking {..} QF.QueryForm {..} slot = SimpleEvent {..} eventFromBooking Booking {..} QF.QueryForm {..} slot = SimpleEvent {..}
......
...@@ -261,7 +261,6 @@ listUpcoming (GoogleCxt env) cid lookahead = do ...@@ -261,7 +261,6 @@ listUpcoming (GoogleCxt env) cid lookahead = do
-- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m () -- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
-- sayEvent prefix SimpleEvent {..} = -- sayEvent prefix SimpleEvent {..} =
-- say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary -- say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary
-- | Convert an event into a local time zone. -- | Convert an event into a local time zone.
applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
applyTz tz ev = applyTz tz ev =
......
...@@ -24,16 +24,15 @@ module Handlers ...@@ -24,16 +24,15 @@ module Handlers
, getVersionR , getVersionR
) where ) where
import BookingForm (b3Class, inputSize, labelSize)
import qualified BookingForm as BF import qualified BookingForm as BF
import BookingForm (b3Class, inputSize, labelSize)
import Calendar import Calendar
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import qualified Data.SortedList as SL import qualified Data.SortedList as SL
import Data.Time.Clock (getCurrentTime, addUTCTime) import Data.Time.Clock (addUTCTime, getCurrentTime)
import qualified Network.Wai import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
import Development.GitRev import Development.GitRev
import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
import qualified FreshCache as FC import qualified FreshCache as FC
import Import import Import
import qualified QueryForm as QF import qualified QueryForm as QF
...@@ -69,9 +68,7 @@ formSuccess ((formResult, _), _) = ...@@ -69,9 +68,7 @@ formSuccess ((formResult, _), _) =
getAvailR :: Handler Html getAvailR :: Handler Html
getAvailR = do getAvailR = do
QF.QueryForm {..} <- formSuccess =<< runFormGet (QF.queryForm "" Nothing) QF.QueryForm {..} <- formSuccess =<< runFormGet (QF.queryForm "" Nothing)
App { appSettings = AppSettings {..} App {appSettings = AppSettings {..}, appCalendarCache} <- getYesod
, appCalendarCache
} <- getYesod
earliest <- addUTCTime appLeadTime <$> liftIO getCurrentTime earliest <- addUTCTime appLeadTime <$> liftIO getCurrentTime
daysWithSlots <- daysWithSlots <-
groupByDay . groupByDay .
...@@ -99,12 +96,14 @@ getBookR = do ...@@ -99,12 +96,14 @@ getBookR = do
showWhenWhere :: Handler (QF.QueryForm, QF.TimeSlot, Widget) showWhenWhere :: Handler (QF.QueryForm, QF.TimeSlot, Widget)
showWhenWhere = do showWhenWhere = do
AppSettings{appDefaultTimeZone} <- appSettings <$> getYesod AppSettings {appDefaultTimeZone} <- appSettings <$> getYesod
(q@QF.QueryForm {..}, s@QF.TimeSlot {..}) <- QF.fromSessionWithSlot (q@QF.QueryForm {..}, s@QF.TimeSlot {..}) <- QF.fromSessionWithSlot
let inOtherZone = let inOtherZone =
if queryTzLabel == appDefaultTimeZone then Nothing if queryTzLabel == appDefaultTimeZone
else Just $ utcToLocalTimeTZ (tzByLabel appDefaultTimeZone) then Nothing
$ localTimeToUTCTZ (tzByLabel queryTzLabel) slotLocal else Just $
utcToLocalTimeTZ (tzByLabel appDefaultTimeZone) $
localTimeToUTCTZ (tzByLabel queryTzLabel) slotLocal
return (q, s, $(widgetFile "when-where")) return (q, s, $(widgetFile "when-where"))
postBookR :: Handler Html postBookR :: Handler Html
...@@ -129,7 +128,7 @@ postBookR = do ...@@ -129,7 +128,7 @@ postBookR = do
getFinalR :: Handler Html getFinalR :: Handler Html
getFinalR = do getFinalR = do
(QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere (QF.QueryForm {..}, QF.TimeSlot {..}, whenWhere) <- showWhenWhere
BF.Booking{..} <- BF.fromSession BF.Booking {..} <- BF.fromSession
defaultLayout $(widgetFile "final") defaultLayout $(widgetFile "final")
getClearR :: Handler Html getClearR :: Handler Html
...@@ -148,7 +147,12 @@ getRobotsR = ...@@ -148,7 +147,12 @@ getRobotsR =
return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt") return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")
getVersionR :: Handler Text getVersionR :: Handler Text
getVersionR = do getVersionR
req <- reqWaiRequest <$> getRequest -- req <- reqWaiRequest <$> getRequest
let hs = foldMap (\(h,v) -> tshow h <> ": " <> tshow v <> "\n") $ Network.Wai.requestHeaders req -- let hs = foldMap (\(h,v) -> tshow h <> ": " <> tshow v <> "\n") $ Network.Wai.requestHeaders req
return $ hs <> "\n" <> $(gitHash) <> if $(gitDirty) then "+" else "" = do
return $
$(gitHash) <>
if $(gitDirty)
then "+"
else ""
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
...@@ -40,10 +40,10 @@ module QueryForm ...@@ -40,10 +40,10 @@ module QueryForm
) where ) where
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import qualified Data.Time.Format as TF import qualified Data.Time.Format as TF
import Data.Time.LocalTime (LocalTime) import Data.Time.LocalTime (LocalTime)
import Import import Import
import qualified Data.Map as Map
import Text.Blaze (ToMarkup (..)) import Text.Blaze (ToMarkup (..))
import Text.Julius (RawJS (..), ToJavascript (..)) import Text.Julius (RawJS (..), ToJavascript (..))
...@@ -215,7 +215,7 @@ prettyTz' = concatMap tzChars ...@@ -215,7 +215,7 @@ prettyTz' = concatMap tzChars
where where
tzChars '_' = " " tzChars '_' = " "
tzChars '/' = " » " tzChars '/' = " » "
tzChars c = singleton c tzChars c = singleton c
prettyTz :: TZLabelW -> Text prettyTz :: TZLabelW -> Text
prettyTz = prettyTz' . toPathPiece prettyTz = prettyTz' . toPathPiece
...@@ -225,16 +225,15 @@ zonesByContinent = ...@@ -225,16 +225,15 @@ zonesByContinent =
Map.fromList $ map continent $ groupAllOn fst $ map splitTz allZones Map.fromList $ map continent $ groupAllOn fst $ map splitTz allZones
where where
allZones :: [TZLabelW] allZones :: [TZLabelW]
allZones = [minBound..maxBound] allZones = [minBound .. maxBound]
splitTz :: TZLabelW -> (Text, (Text, Text)) splitTz :: TZLabelW -> (Text, (Text, Text))
splitTz tz = (cont, (txt, prettyTz' (drop 1 city))) splitTz tz = (cont, (txt, prettyTz' (drop 1 city)))
where (cont, city) = break (== '/') txt where
txt = toPathPiece tz (cont, city) = break (== '/') txt
txt = toPathPiece tz
continent :: [(Text,a)] -> (Text,[a]) continent :: [(Text, a)] -> (Text, [a])
continent [] = error "zonesByContinent: Impossible" continent [] = error "zonesByContinent: Impossible"
continent ((x,y):xys) = (x, y : map snd xys) continent ((x, y):xys) = (x, y : map snd xys)
-- | Present time zone choices. -- | Present time zone choices.
tzSelectorField :: Text -> Field Handler TZLabelW tzSelectorField :: Text -> Field Handler TZLabelW
...@@ -242,9 +241,9 @@ tzSelectorField idReset = Field {..} ...@@ -242,9 +241,9 @@ tzSelectorField idReset = Field {..}
where where
fieldEnctype = UrlEncoded fieldEnctype = UrlEncoded
fieldParse (txt:_) _ = return $ Right $ fromPathPiece txt fieldParse (txt:_) _ = return $ Right $ fromPathPiece txt
fieldParse _ _ = return $ Left $ SomeMessage $ MsgInvalidEntry "Timezone" fieldParse _ _ = return $ Left $ SomeMessage $ MsgInvalidEntry "Timezone"
fieldView _ name attrs val _ = do fieldView _ name attrs val _ = do
AppSettings{appDefaultTimeZone} <- appSettings <$> getYesod AppSettings {appDefaultTimeZone} <- appSettings <$> getYesod
(idShowDefaultTz, idTextTz, idSelectTz) <- newIdent3 (idShowDefaultTz, idTextTz, idSelectTz) <- newIdent3
let currentTz = toPathPiece $ either (const appDefaultTimeZone) id val let currentTz = toPathPiece $ either (const appDefaultTimeZone) id val
isDefaultTz = currentTz == toPathPiece appDefaultTimeZone isDefaultTz = currentTz == toPathPiece appDefaultTimeZone
...@@ -256,7 +255,10 @@ qControl = "qcontrol" ...@@ -256,7 +255,10 @@ qControl = "qcontrol"
-- | The complete query form for the front page. -- | The complete query form for the front page.
queryForm :: queryForm ::
Text -> Maybe QueryForm -> Html -> MForm Handler (FormResult QueryForm, Widget) Text
-> Maybe QueryForm
-> Html
-> MForm Handler (FormResult QueryForm, Widget)
queryForm idReset qOpt extra = do queryForm idReset qOpt extra = do
AppSettings {..} <- appSettings <$> getYesod AppSettings {..} <- appSettings <$> getYesod
let qs n = "" {fsName = Just (qiName n), fsAttrs = [("class", qControl)]} let qs n = "" {fsName = Just (qiName n), fsAttrs = [("class", qControl)]}
......
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-| {-|
Module: Settings Module: Settings
...@@ -111,9 +111,9 @@ data AppSettings = AppSettings ...@@ -111,9 +111,9 @@ data AppSettings = AppSettings
-- ^ Valid lengths of appointments, in minutes -- ^ Valid lengths of appointments, in minutes
, appCacheExpiry :: NominalDiffTime , appCacheExpiry :: NominalDiffTime
-- ^ Cached calendar data older than this will be refreshed -- ^ Cached calendar data older than this will be refreshed
, appProviderName :: Maybe Text , appProviderName :: Maybe Text
-- ^ Name of person/service providing appointments -- ^ Name of person/service providing appointments
, appProviderAvatar :: Maybe Text , appProviderAvatar :: Maybe Text
-- ^ URL to image of person/service providing appointments -- ^ URL to image of person/service providing appointments
} }
...@@ -158,7 +158,7 @@ instance FromJSON AppSettings where ...@@ -158,7 +158,7 @@ instance FromJSON AppSettings where
appFreeCalendarId <- o .: "free-calendar" appFreeCalendarId <- o .: "free-calendar"
appBusyCalendarId <- o .: "busy-calendar" appBusyCalendarId <- o .: "busy-calendar"
appLookaheadWeeks <- o .: "look-ahead-weeks" appLookaheadWeeks <- o .: "look-ahead-weeks"
appLeadTime <- (*60) <$> (o .: "lead-time-minutes") appLeadTime <- (* 60) <$> (o .: "lead-time-minutes")
appApptLengthsMinutes <- o .: "appointment-lengths-minutes" appApptLengthsMinutes <- o .: "appointment-lengths-minutes"
appProviderName <- o .:? "provider-name" appProviderName <- o .:? "provider-name"
appProviderAvatar <- o .:? "provider-avatar" appProviderAvatar <- o .:? "provider-avatar"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment