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
......@@ -7,17 +7,18 @@
{-# 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)
......@@ -27,21 +28,29 @@ import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings,
import Network.Wai.Handler.Warp
( Settings,
defaultSettings,
defaultShouldDisplayException,
getPort, runSettings,
setHost, setOnException,
setPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
getPort,
runSettings,
setHost,
setOnException,
setPort
)
import Network.Wai.Middleware.RequestLogger
( Destination (Logger),
IPAddrSource (..),
OutputFormat (..),
destination,
mkRequestLogger,
outputFormat)
import System.Log.FastLogger (defaultBufSize,
outputFormat
)
import System.Log.FastLogger
( defaultBufSize,
newStdoutLoggerSet,
toLogStr)
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
( if appMutableStatic
then staticDevel
else static)
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
unsafeHandler partialApp
$ FC.newCache appCacheExpiry
$ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
fromWeeks appLookaheadWeeks
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId
$ fromWeeks appLookaheadWeeks
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......@@ -93,28 +104,31 @@ makeLogWare foundation =
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
else
Apache
( if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
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
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))
(toLogStr $ "Exception from Warp: " ++ show e)
)
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
......@@ -135,9 +149,9 @@ develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain
appMain =
-- Get the settings from all relevant sources
= do
do
settings <-
loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
......
......@@ -11,16 +11,17 @@ Description: TODO
TODO
-}
module BookingForm
( Booking(..)
, bookingMForm
, eventFromBooking
, toSession
, fromSessionMaybe
, fromSession
, b3Class
, inputSize
, labelSize
) where
( Booking (..),
bookingMForm,
eventFromBooking,
toSession,
fromSessionMaybe,
fromSession,
b3Class,
inputSize,
labelSize
)
where
import Calendar
import Control.Monad.Trans.Maybe
......@@ -34,12 +35,14 @@ 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)
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,10 +121,10 @@ 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
......@@ -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.
......@@ -10,14 +10,15 @@
{-# LANGUAGE TypeFamilies #-}
module Foundation
( App(..)
, Handler
, Widget
, Form
, Route(..)
, resourcesApp
, unsafeHandler
) where
( App (..),
Handler,
Widget,
Form,
Route (..),
resourcesApp,
unsafeHandler
)
where
import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource)
......@@ -36,13 +37,14 @@ import Yesod.Default.Util (addStaticContentExternal)
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appCalendarCxt :: CalendarContext
, appCalendarCache :: FC.Cache (HandlerFor App) (SL.SortedList SimpleEventUTC)
data App
= App
{ appSettings :: AppSettings,
appStatic :: Static, -- ^ Settings for static file serving.
appHttpManager :: Manager,
appLogger :: Logger,
appCalendarCxt :: CalendarContext,
appCalendarCache :: FC.Cache (HandlerFor App) (SL.SortedList SimpleEventUTC)
-- ^ Fetch latest available times from the calendars. Return cached
-- version if it's less than given age, which defaults to
-- 'appCacheExpiry'.
......@@ -66,6 +68,7 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
instance MC.MonadCatch (HandlerFor App) where
catch = Pre.catch
addStylesheetL :: Route App -> Text -> [(Text, Text)] -> Widget
......@@ -83,20 +86,23 @@ addScriptL route cdn attrs =
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod App where
approot :: Approot App
approot =
ApprootRequest $ \app req ->
case appRoot $ appSettings app of
Nothing -> getApprootText guessApproot app req
Just root -> root
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend _ =
Just <$>
defaultClientSessionBackend
Just
<$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
......@@ -106,6 +112,7 @@ instance Yesod App where
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
defaultLayout :: Widget -> Handler Html
defaultLayout widget = do
master <- getYesod
......@@ -117,8 +124,8 @@ instance Yesod App where
addScriptL
(StaticR js_jquery_3_3_1_min_js)
"https://code.jquery.com/jquery-3.3.1.min.js"
[ ("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=")
, ("crossorigin", "anonymous")
[ ("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8="),
("crossorigin", "anonymous")
]
addScriptL
(StaticR js_js_cookie_2_2_0_min_js)
......@@ -129,14 +136,16 @@ instance Yesod App where
addStylesheetL
(StaticR css_bootstrap_3_3_7_min_css)
"https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"
[ ( "integrity"
, "sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u")
, ("crossorigin", "anonymous")
[ ( "integrity",
"sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u"
),
("crossorigin", "anonymous")
]
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
isAuthorized ::
Route App -- ^ The route the user is visiting.
isAuthorized
:: Route App -- ^ The route the user is visiting.
-> Bool -- ^ Whether or not this is a "write" request.
-> Handler AuthResult
-- Routes not requiring authenitcation.
......@@ -144,12 +153,13 @@ instance Yesod App where
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent ::
Text -- ^ The file extension
addStaticContent
:: Text -- ^ The file extension
-> Text -- ^ The MIME content type
-> LByteString -- ^ The contents of the file
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
......@@ -164,27 +174,32 @@ instance Yesod App where
ext
mime
content
-- Generate a unique filename based on the content itself
where
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $
appShouldLogAll (appSettings app) ||
level == LevelWarn || level == LevelError
return
$ appShouldLogAll (appSettings app)
|| level
== LevelWarn
|| level
== LevelError
makeLogger :: App -> IO Logger
makeLogger = return . appLogger
-- Define breadcrumbs.
instance YesodBreadcrumbs App
instance YesodBreadcrumbs App where
-- Takes the route that the user is currently on, and returns a tuple
-- of the 'Text' that you want the label to display, and a previous
-- breadcrumb route.
where
breadcrumb ::
Route App -- ^ The route the user is visiting currently.
breadcrumb
:: Route App -- ^ The route the user is visiting currently.
-> Handler (Text, Maybe (Route App))
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb _ = return ("home", Nothing)
......@@ -192,6 +207,7 @@ instance YesodBreadcrumbs App
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
renderMessage :: App -> [Lang] -> FormMessage -> Text
renderMessage _ _ = defaultFormMessage
......@@ -199,6 +215,7 @@ instance RenderMessage App FormMessage where
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod applications.
instance HasHttpManager App where
getHttpManager :: App -> Manager
getHttpManager = appHttpManager
......
......@@ -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)
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.
......
......@@ -12,17 +12,18 @@ 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
......@@ -41,9 +42,9 @@ 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
do
App {appCalendarCache} <- getYesod
void $ async $ FC.readCache appCalendarCache
-- Produce form for query and display parameters: appointment length,
......@@ -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
......
{-# LANGUAGE OverloadedStrings #-}
module Import.NoFoundation
( module Import
, pluralN
, fromWeeks
, fromMinutes
) where
( module Import,
pluralN,
fromWeeks,
fromMinutes
)
where
import Calendar as Import (CalendarContext,
SimpleEventUTC)
import Calendar as Import
( CalendarContext,
SimpleEventUTC
)
import ClassyPrelude.Yesod as Import
import Data.Time.Clock (NominalDiffTime)
import Settings as Import
......
......@@ -17,27 +17,28 @@ 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
( 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
......@@ -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
-- | Default is 12-hour time.
instance Default TimeFmt where
def = Time12h
-- | Format strings to be used with 'Data.Time.Format'.
......@@ -72,25 +76,29 @@ timeFmt Time24h = "%H:%M"
-- | Query data from the front page. The time slot chosen will be
-- packaged separately.
data QueryForm = QueryForm
{ queryApptLength :: Int
, queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
} deriving (Show)
data QueryForm
= QueryForm
{ queryApptLength :: Int,
queryTimeFmt :: TimeFmt,
queryTzLabel :: TZLabelW,
queryLocation :: Location
}
deriving (Show)
-- | Represent field names used in a form. This abstraction gives
-- cleaner access to fields from jQuery and JS.
data QueryName
= QueryInput { qiName :: Text }
| QuerySelect { qiName :: Text }
| QueryChecked { qiName :: Text }
= QueryInput {qiName :: Text}
| QuerySelect {qiName :: Text}
| QueryChecked {qiName :: Text}
deriving (Eq, Show)
instance ToJavascript QueryName where
toJavascript = toJavascript . String . qiName
instance ToMarkup QueryName where
toMarkup = toMarkup . qiName
-- | Produce a jQuery selector for the given field name.
......@@ -122,10 +130,10 @@ idLocation = QueryChecked "loc"
-- | Serialize the query settings to a set of HTTP parameters.
toParams :: QueryForm -> [(Text, Text)]