Commit d55a1be9 authored by Christopher League's avatar Christopher League

ormolu formatting

parent 1b3f7ba0
Pipeline #831 passed with stage
in 2 minutes and 12 seconds
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
( getApplicationDev,
appMain,
develMain,
makeFoundation,
makeLogWare,
-- * for DevelMain
, getApplicationRepl
, shutdownApp
getApplicationRepl,
shutdownApp,
-- * for GHCI
, handler
) where
handler
)
where
import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc, logInfoN)
import qualified FreshCache as FC
import Handlers
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings,
defaultSettings,
defaultShouldDisplayException,
getPort, runSettings,
setHost, setOnException,
setPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..),
destination,
mkRequestLogger,
outputFormat)
import System.Log.FastLogger (defaultBufSize,
newStdoutLoggerSet,
toLogStr)
import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc, logInfoN)
import qualified FreshCache as FC
import Handlers
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp
( Settings,
defaultSettings,
defaultShouldDisplayException,
getPort,
runSettings,
setHost,
setOnException,
setPort
)
import Network.Wai.Middleware.RequestLogger
( Destination (Logger),
IPAddrSource (..),
OutputFormat (..),
destination,
mkRequestLogger,
outputFormat
)
import System.Log.FastLogger
( defaultBufSize,
newStdoutLoggerSet,
toLogStr
)
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
......@@ -57,24 +66,26 @@ makeFoundation appSettings@AppSettings {..} = do
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic
then staticDevel
else static)
( if appMutableStatic
then staticDevel
else static
)
appStaticDir
let partialApp = App {..}
where
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
appCalendarCache = error "partialApp loop: Accessing appCalendarCache"
logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv
whenM (shouldLogIO partialApp "" lv)
. messageLoggerSource partialApp appLogger loc src lv
appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
appCalendarCache <-
unsafeHandler partialApp $
FC.newCache appCacheExpiry $ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
fromWeeks appLookaheadWeeks
unsafeHandler partialApp
$ FC.newCache appCacheExpiry
$ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId
$ fromWeeks appLookaheadWeeks
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......@@ -82,7 +93,7 @@ makeFoundation appSettings@AppSettings {..} = do
makeApplication :: App -> IO Application
makeApplication foundation = do
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
......@@ -93,29 +104,32 @@ makeLogWare foundation =
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
else
Apache
( if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket
),
destination = Logger $ loggerSet $ appLogger foundation
}
-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
setPort (appPort $ appSettings foundation) $
setHost (appHost $ appSettings foundation) $
setOnException
(\_req e ->
when (defaultShouldDisplayException e) $
messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
$ setOnException
( \_req e ->
when (defaultShouldDisplayException e)
$ messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e)
)
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
......@@ -135,21 +149,21 @@ develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain
-- Get the settings from all relevant sources
= do
settings <-
loadYamlSettingsArgs
appMain =
-- Get the settings from all relevant sources
do
settings <-
loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
useEnv
-- Generate the foundation from the settings
foundation <- makeFoundation settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app
runSettings (warpSettings foundation) app
--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
......
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module: BookingForm
......@@ -11,35 +11,38 @@ Description: TODO
TODO
-}
module BookingForm
( Booking(..)
, bookingMForm
, eventFromBooking
, toSession
, fromSessionMaybe
, fromSession
, b3Class
, inputSize
, labelSize
) where
import Calendar
import Control.Monad.Trans.Maybe
import Data.Aeson ((.!=), (.:?))
import qualified Data.Aeson as Js
import Data.Function ((&))
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones
import Import
import qualified Network.HTTP.Simple as H
import qualified QueryForm as QF
import qualified Yesod.Form.Bootstrap3 as B3
data Booking = Booking
{ bookName :: Text
, bookEmail :: Text
, bookSubject :: Text
, bookContact :: Maybe Text
} deriving (Show)
( Booking (..),
bookingMForm,
eventFromBooking,
toSession,
fromSessionMaybe,
fromSession,
b3Class,
inputSize,
labelSize
)
where
import Calendar
import Control.Monad.Trans.Maybe
import Data.Aeson ((.!=), (.:?))
import qualified Data.Aeson as Js
import Data.Function ((&))
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones
import Import
import qualified Network.HTTP.Simple as H
import qualified QueryForm as QF
import qualified Yesod.Form.Bootstrap3 as B3
data Booking
= Booking
{ bookName :: Text,
bookEmail :: Text,
bookSubject :: Text,
bookContact :: Maybe Text
}
deriving (Show)
toSession :: MonadHandler m => Booking -> m ()
toSession Booking {..} = do
......@@ -77,12 +80,12 @@ submit = do
bookingAForm :: Maybe Booking -> AForm Handler Booking
bookingAForm bOpt =
Booking <$> areq textField name (bookName <$> bOpt) <*>
areq emailField email (bookEmail <$> bOpt) <*>
areq textField subject (bookSubject <$> bOpt) <*>
aopt textField contact (bookContact <$> bOpt) <*
formToAForm recaptcha <*
formToAForm submit
Booking <$> areq textField name (bookName <$> bOpt)
<*> areq emailField email (bookEmail <$> bOpt)
<*> areq textField subject (bookSubject <$> bOpt)
<*> aopt textField contact (bookContact <$> bOpt)
<* formToAForm recaptcha
<* formToAForm submit
where
name = bfs "*Name" "Who are you?"
email = bfs "*Email" "You must use a valid email address"
......@@ -90,12 +93,15 @@ bookingAForm bOpt =
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?"
data RecaptchaResponse = RecaptchaResponse
{ rrSuccess :: Bool
, rrErrors :: [Text]
} deriving (Show)
data RecaptchaResponse
= RecaptchaResponse
{ rrSuccess :: Bool,
rrErrors :: [Text]
}
deriving (Show)
instance Js.FromJSON RecaptchaResponse where
parseJSON =
Js.withObject "RecaptchaResponse" $ \o -> do
rrSuccess <- o .: "success"
......@@ -115,11 +121,11 @@ recaptcha =
H.parseRequest
"POST https://www.google.com/recaptcha/api/siteverify"
let req =
req' & H.setRequestManager mgr &
H.setRequestBodyURLEncoded
[ ("secret", encodeUtf8 secret)
, ("response", encodeUtf8 response)
]
req' & H.setRequestManager mgr
& H.setRequestBodyURLEncoded
[ ("secret", encodeUtf8 secret),
("response", encodeUtf8 response)
]
resp <- H.getResponseBody <$> H.httpJSON req
if rrSuccess resp
then return (FormSuccess (), [])
......@@ -164,8 +170,8 @@ b3Class g =
B3.ColMd n -> "col-md-" <> 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
where
horiz =
......
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
......@@ -13,32 +13,35 @@ existing one is used. If it is requested after the time is expired, we
automatically refresh it. Should be thread-safe.
-}
module FreshCache
( Cache
, newCache
, readCache
, invalidateCache
, cacheDemo
) where
( Cache,
newCache,
readCache,
invalidateCache,
cacheDemo
)
where
import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay)
import Data.Time.Clock (NominalDiffTime, diffUTCTime)
import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay)
import Data.Time.Clock (NominalDiffTime, diffUTCTime)
data CacheData a = CacheData
{ value :: a
, retrievedAt :: UTCTime
}
data CacheData a
= CacheData
{ value :: a,
retrievedAt :: UTCTime
}
data CacheMeta m a = CacheMeta
{ content :: Maybe (CacheData a)
, maxAge :: NominalDiffTime
, refresh :: m a
}
data CacheMeta m a
= CacheMeta
{ content :: Maybe (CacheData a),
maxAge :: NominalDiffTime,
refresh :: m a
}
-- | The cache structure. Saves the value 'a' which can be refreshed or
-- accessed within the monad 'm'.
newtype Cache m a =
Cache (MVar (CacheMeta m a))
newtype Cache m a
= Cache (MVar (CacheMeta m a))
-- | Create a new cache by running the action and saving it with a
-- timestamp.
......
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: Handlers
......@@ -12,53 +12,54 @@ Description: TODO
TODO
-}
module Handlers
( getFaviconR
, getRobotsR
, getHomeR
, getAvailR
, postHomeR
, getBookR
, postBookR
, getFinalR
, getClearR
, getVersionR
) where
( getFaviconR,
getRobotsR,
getHomeR,
getAvailR,
postHomeR,
getBookR,
postBookR,
getFinalR,
getClearR,
getVersionR
)
where
import BookingForm (b3Class, inputSize, labelSize)
import qualified BookingForm as BF
import Calendar
import Control.Monad.Trans.Maybe
import Data.FileEmbed (embedFile)
import qualified Data.SortedList as SL
import Data.Time.Clock (addUTCTime, getCurrentTime)
import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
import qualified FreshCache as FC
import Import
import qualified QueryForm as QF
import Text.Hamlet (shamletFile)
import Text.Julius (RawJS (..))
import BookingForm (b3Class, inputSize, labelSize)
import qualified BookingForm as BF
import Calendar
import Control.Monad.Trans.Maybe
import Data.FileEmbed (embedFile)
import qualified Data.SortedList as SL
import Data.Time.Clock (addUTCTime, getCurrentTime)
import Data.Time.Zones (localTimeToUTCTZ, utcToLocalTimeTZ)
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
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
bOpt <- runMaybeT BF.fromSessionMaybe
(idReset, idSpinner, idAvail, idAlert) <- newIdent4
(queryWidget, enctype) <- generateFormPost $ QF.queryForm idReset qOpt
defaultLayout $(widgetFile "homepage")
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
bOpt <- runMaybeT BF.fromSessionMaybe
(idReset, idSpinner, idAvail, idAlert) <- newIdent4
(queryWidget, enctype) <- generateFormPost $ QF.queryForm idReset qOpt
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!"]
FormMissing -> invalidArgs ["Missing form data!"]
FormFailure errors -> invalidArgs errors
FormSuccess result -> return result
......@@ -70,12 +71,12 @@ getAvailR = do
App {appSettings = AppSettings {..}, appCalendarCache} <- getYesod
earliest <- addUTCTime appLeadTime <$> liftIO getCurrentTime
daysWithSlots <-
groupByDay .
SL.map (applyTz (tzByLabel queryTzLabel)) .
SL.dropWhile ((< earliest) . seStart) .
partitionSlots (headMay appApptLengthsMinutes) queryApptLength .
SL.filter (summaryMatches (locSearch queryLocation)) <$>
FC.readCache appCalendarCache
groupByDay
. SL.map (applyTz (tzByLabel queryTzLabel))
. SL.dropWhile ((< earliest) . seStart)
. partitionSlots (headMay appApptLengthsMinutes) queryApptLength
. SL.filter (summaryMatches (locSearch queryLocation))
<$> FC.readCache appCalendarCache
return $(shamletFile "templates/avail.hamlet")
postHomeR :: Handler Html
......@@ -100,9 +101,10 @@ showWhenWhere = do
let inOtherZone =
if queryTzLabel == appDefaultTimeZone
then Nothing
else Just $
utcToLocalTimeTZ (tzByLabel appDefaultTimeZone) $
localTimeToUTCTZ (tzByLabel queryTzLabel) slotLocal
else
Just
$ utcToLocalTimeTZ (tzByLabel appDefaultTimeZone)
$ localTimeToUTCTZ (tzByLabel queryTzLabel) slotLocal
return (q, s, $(widgetFile "when-where"))
postBookR :: Handler Html
......@@ -138,8 +140,9 @@ getClearR = clearSession >> redirect HomeR
getFaviconR :: Handler TypedContent
getFaviconR = do
cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $
TypedContent "image/x-icon" $ toContent $(embedFile "config/favicon.ico")
return
$ TypedContent "image/x-icon"
$ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent
getRobotsR =
......
module Import
( module Import
) where
)
where
import Foundation as Import
import Import.NoFoundation as Import
import Foundation as Import
import Import.NoFoundation as Import
newIdent2 :: MonadHandler m => m (Text, Text)
newIdent2 = (,) <$> newIdent <*> newIdent
......
{-# LANGUAGE OverloadedStrings #-}
module Import.NoFoundation
( module Import
, pluralN
, fromWeeks
, fromMinutes
) where
( module Import,
pluralN,
fromWeeks,
fromMinutes
)
where
import Calendar as Import (CalendarContext,
SimpleEventUTC)
import ClassyPrelude.Yesod as Import
import Data.Time.Clock (NominalDiffTime)
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import
import Calendar as Import
( CalendarContext,
SimpleEventUTC
)
import ClassyPrelude.Yesod as Import
import Data.Time.Clock (NominalDiffTime)
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import
pluralN :: Int -> Text -> Text -> Text
pluralN 1 x _ = "1 " <> x
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module: QueryForm
......@@ -17,35 +17,36 @@ Form for front page, to query available times. Consists of the
location, appointment length, time format, and time zone.
-}
module QueryForm
( TimeFmt(..)
, QueryForm(..)
, QueryName(qiName)
, idApptLength
, idTimeFmt
, idTzLabel
, idLocation
, toParams
, toSession
, fromSession
, queryForm
, TimeSlot(..)
, idTimeSlot
, timeInput
, toSessionWithSlot
, fromSessionWithSlot
, noSessionError
, showDate
, showTime
, prettyTz
) where
import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import qualified Data.Time.Format as TF
import Data.Time.LocalTime (LocalTime)
import Import
import Text.Blaze (ToMarkup (..))
import Text.Julius (RawJS (..), ToJavascript (..))
( TimeFmt (..),
QueryForm (..),
QueryName (qiName),
idApptLength,
idTimeFmt,
idTzLabel,
idLocation,
toParams,
toSession,
fromSession,
queryForm,
TimeSlot (..),
idTimeSlot,
timeInput,
toSessionWithSlot,
fromSessionWithSlot,
noSessionError,
showDate,
showTime,
prettyTz
)
where
import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import qualified Data.Time.Format as TF
import Data.Time.LocalTime (LocalTime)
import Import
import Text.Blaze (ToMarkup (..))
import Text.Julius (RawJS (..), ToJavascript (..))
-- | Times can be displayed in 12- or 24-hour format.
data TimeFmt
......@@ -55,14 +56,17 @@ data TimeFmt
-- | Time format serialization for session and GET/POST parameters.
instance PathPiece TimeFmt where
toPathPiece Time12h = "12h"
toPathPiece Time24h = "24h"
fromPathPiece "12h" = Just Time12h
fromPathPiece "24h" = Just Time24h
fromPathPiece _ = Nothing
fromPathPiece _ = Nothing
-- | Default is 12-hour time.
instance Default TimeFmt where
def = Time12h
-- | Format strings to be used with 'Data.Time.Format'.
......@@ -72,33 +76,37 @@ timeFmt Time24h = "%H:%M"
-- | Query data from the front page. The time slot chosen will be
-- packaged separately.
data QueryForm = QueryForm
{ queryApptLength :: Int