Commit d55a1be9 authored by Christopher League's avatar Christopher League
Browse files

ormolu formatting

parent 1b3f7ba0
Pipeline #831 passed with stage
in 2 minutes and 12 seconds
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application module Application
( getApplicationDev ( getApplicationDev,
, appMain appMain,
, develMain develMain,
, makeFoundation makeFoundation,
, makeLogWare makeLogWare,
-- * for DevelMain -- * for DevelMain
, getApplicationRepl getApplicationRepl,
, shutdownApp shutdownApp,
-- * for GHCI -- * for GHCI
, handler handler
) where )
where
import qualified Calendar as Cal import qualified Calendar as Cal
import Control.Monad.Logger (liftLoc, logInfoN) import Control.Monad.Logger (liftLoc, logInfoN)
import qualified FreshCache as FC import qualified FreshCache as FC
import Handlers import Handlers
import Import import Import
import Language.Haskell.TH.Syntax (qLocation) import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware) import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, import Network.Wai.Handler.Warp
defaultSettings, ( Settings,
defaultShouldDisplayException, defaultSettings,
getPort, runSettings, defaultShouldDisplayException,
setHost, setOnException, getPort,
setPort) runSettings,
import Network.Wai.Middleware.RequestLogger (Destination (Logger), setHost,
IPAddrSource (..), setOnException,
OutputFormat (..), setPort
destination, )
mkRequestLogger, import Network.Wai.Middleware.RequestLogger
outputFormat) ( Destination (Logger),
import System.Log.FastLogger (defaultBufSize, IPAddrSource (..),
newStdoutLoggerSet, OutputFormat (..),
toLogStr) destination,
mkRequestLogger,
outputFormat
)
import System.Log.FastLogger
( defaultBufSize,
newStdoutLoggerSet,
toLogStr
)
-- This line actually creates our YesodDispatch instance. It is the second half -- 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 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
...@@ -57,24 +66,26 @@ makeFoundation appSettings@AppSettings {..} = do ...@@ -57,24 +66,26 @@ makeFoundation appSettings@AppSettings {..} = do
appHttpManager <- getGlobalManager appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <- appStatic <-
(if appMutableStatic ( if appMutableStatic
then staticDevel then staticDevel
else static) else static
)
appStaticDir appStaticDir
let partialApp = App {..} let partialApp = App {..}
where where
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt" appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
appCalendarCache = error "partialApp loop: Accessing appCalendarCache" appCalendarCache = error "partialApp loop: Accessing appCalendarCache"
logFunc loc src lv = logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) . whenM (shouldLogIO partialApp "" lv)
messageLoggerSource partialApp appLogger loc src lv . messageLoggerSource partialApp appLogger loc src lv
appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
appCalendarCache <- appCalendarCache <-
unsafeHandler partialApp $ unsafeHandler partialApp
FC.newCache appCacheExpiry $ do $ FC.newCache appCacheExpiry
logInfoN "Refreshing calendar cache" $ do
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $ logInfoN "Refreshing calendar cache"
fromWeeks appLookaheadWeeks Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId
$ fromWeeks appLookaheadWeeks
return App {..} return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
...@@ -82,7 +93,7 @@ makeFoundation appSettings@AppSettings {..} = do ...@@ -82,7 +93,7 @@ makeFoundation appSettings@AppSettings {..} = do
makeApplication :: App -> IO Application makeApplication :: App -> IO Application
makeApplication foundation = do makeApplication foundation = do
logWare <- makeLogWare foundation logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain return $ logWare $ defaultMiddlewaresNoLogging appPlain
...@@ -93,29 +104,32 @@ makeLogWare foundation = ...@@ -93,29 +104,32 @@ makeLogWare foundation =
{ outputFormat = { outputFormat =
if appDetailedRequestLogging $ appSettings foundation if appDetailedRequestLogging $ appSettings foundation
then Detailed True then Detailed True
else Apache else
(if appIpFromHeader $ appSettings foundation Apache
then FromFallback ( if appIpFromHeader $ appSettings foundation
else FromSocket) then FromFallback
, destination = Logger $ loggerSet $ appLogger foundation else FromSocket
} ),
destination = Logger $ loggerSet $ appLogger foundation
}
-- | Warp settings for the given foundation value. -- | Warp settings for the given foundation value.
warpSettings :: App -> Settings warpSettings :: App -> Settings
warpSettings foundation = warpSettings foundation =
setPort (appPort $ appSettings foundation) $ setPort (appPort $ appSettings foundation)
setHost (appHost $ appSettings foundation) $ $ setHost (appHost $ appSettings foundation)
setOnException $ setOnException
(\_req e -> ( \_req e ->
when (defaultShouldDisplayException e) $ when (defaultShouldDisplayException e)
messageLoggerSource $ messageLoggerSource
foundation foundation
(appLogger foundation) (appLogger foundation)
$(qLocation >>= liftLoc) $(qLocation >>= liftLoc)
"yesod" "yesod"
LevelError LevelError
(toLogStr $ "Exception from Warp: " ++ show e)) (toLogStr $ "Exception from Warp: " ++ show e)
defaultSettings )
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application. -- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application) getApplicationDev :: IO (Settings, Application)
...@@ -135,21 +149,21 @@ develMain = develMainHelper getApplicationDev ...@@ -135,21 +149,21 @@ develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site. -- | The @main@ function for an executable running this site.
appMain :: IO () appMain :: IO ()
appMain appMain =
-- Get the settings from all relevant sources -- Get the settings from all relevant sources
= do do
settings <- settings <-
loadYamlSettingsArgs loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime -- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue] [configSettingsYmlValue]
-- allow environment variables to override -- allow environment variables to override
useEnv useEnv
-- Generate the foundation from the settings -- Generate the foundation from the settings
foundation <- makeFoundation settings foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation -- Generate a WAI Application from the foundation
app <- makeApplication foundation app <- makeApplication foundation
-- Run the application with Warp -- 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) -- Functions for DevelMain.hs (a way to run the app from GHCi)
......
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-| {-|
Module: BookingForm Module: BookingForm
...@@ -11,35 +11,38 @@ Description: TODO ...@@ -11,35 +11,38 @@ Description: TODO
TODO TODO
-} -}
module BookingForm module BookingForm
( Booking(..) ( Booking (..),
, bookingMForm bookingMForm,
, eventFromBooking eventFromBooking,
, toSession toSession,
, fromSessionMaybe fromSessionMaybe,
, fromSession fromSession,
, b3Class b3Class,
, inputSize inputSize,
, labelSize labelSize
) where )
where
import Calendar
import Control.Monad.Trans.Maybe import Calendar
import Data.Aeson ((.!=), (.:?)) import Control.Monad.Trans.Maybe
import qualified Data.Aeson as Js import Data.Aeson ((.!=), (.:?))
import Data.Function ((&)) import qualified Data.Aeson as Js
import Data.Time.Clock (addUTCTime) import Data.Function ((&))
import Data.Time.Zones import Data.Time.Clock (addUTCTime)
import Import import Data.Time.Zones
import qualified Network.HTTP.Simple as H import Import
import qualified QueryForm as QF import qualified Network.HTTP.Simple as H
import qualified Yesod.Form.Bootstrap3 as B3 import qualified QueryForm as QF
import qualified Yesod.Form.Bootstrap3 as B3
data Booking = Booking
{ bookName :: Text data Booking
, bookEmail :: Text = Booking
, bookSubject :: Text { bookName :: Text,
, bookContact :: Maybe Text bookEmail :: Text,
} deriving (Show) bookSubject :: Text,
bookContact :: Maybe Text
}
deriving (Show)
toSession :: MonadHandler m => Booking -> m () toSession :: MonadHandler m => Booking -> m ()
toSession Booking {..} = do toSession Booking {..} = do
...@@ -77,12 +80,12 @@ submit = do ...@@ -77,12 +80,12 @@ submit = do
bookingAForm :: Maybe Booking -> AForm Handler Booking bookingAForm :: Maybe Booking -> AForm Handler Booking
bookingAForm bOpt = bookingAForm bOpt =
Booking <$> areq textField name (bookName <$> bOpt) <*> Booking <$> areq textField name (bookName <$> bOpt)
areq emailField email (bookEmail <$> bOpt) <*> <*> areq emailField email (bookEmail <$> bOpt)
areq textField subject (bookSubject <$> bOpt) <*> <*> areq textField subject (bookSubject <$> bOpt)
aopt textField contact (bookContact <$> bOpt) <* <*> aopt textField contact (bookContact <$> bOpt)
formToAForm recaptcha <* <* formToAForm recaptcha
formToAForm submit <* formToAForm submit
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"
...@@ -90,12 +93,15 @@ bookingAForm bOpt = ...@@ -90,12 +93,15 @@ bookingAForm bOpt =
bfs "*Subject" "What course are you in? What do you want to talk about?" 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?"
data RecaptchaResponse = RecaptchaResponse data RecaptchaResponse
{ rrSuccess :: Bool = RecaptchaResponse
, rrErrors :: [Text] { rrSuccess :: Bool,
} deriving (Show) rrErrors :: [Text]
}
deriving (Show)
instance Js.FromJSON RecaptchaResponse where instance Js.FromJSON RecaptchaResponse where
parseJSON = parseJSON =
Js.withObject "RecaptchaResponse" $ \o -> do Js.withObject "RecaptchaResponse" $ \o -> do
rrSuccess <- o .: "success" rrSuccess <- o .: "success"
...@@ -115,11 +121,11 @@ recaptcha = ...@@ -115,11 +121,11 @@ recaptcha =
H.parseRequest H.parseRequest
"POST https://www.google.com/recaptcha/api/siteverify" "POST https://www.google.com/recaptcha/api/siteverify"
let req = let req =
req' & H.setRequestManager mgr & req' & H.setRequestManager mgr
H.setRequestBodyURLEncoded & H.setRequestBodyURLEncoded
[ ("secret", encodeUtf8 secret) [ ("secret", encodeUtf8 secret),
, ("response", encodeUtf8 response) ("response", encodeUtf8 response)
] ]
resp <- H.getResponseBody <$> H.httpJSON req resp <- H.getResponseBody <$> H.httpJSON req
if rrSuccess resp if rrSuccess resp
then return (FormSuccess (), []) then return (FormSuccess (), [])
...@@ -164,8 +170,8 @@ b3Class g = ...@@ -164,8 +170,8 @@ 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 :: bookingMForm
Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget) :: Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm = B3.renderBootstrap3 horiz . bookingAForm bookingMForm = B3.renderBootstrap3 horiz . bookingAForm
where where
horiz = horiz =
......
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-| {-|
Module: Calendar Module: Calendar
...@@ -14,46 +14,53 @@ calendars and their events. It supports both Google calendars and a ...@@ -14,46 +14,53 @@ calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging. mock calendar for used for testing and debugging.
-} -}
module Calendar module Calendar
( CalendarScope ( CalendarScope,
, CalendarCredentials CalendarCredentials,
, CalendarContext CalendarContext,
, CalendarId CalendarId,
, SimpleEvent(..) SimpleEvent (..),
, SimpleEventUTC SimpleEventUTC,
, SimpleEventLocal SimpleEventLocal,
, Attendee(..) Attendee (..),
, initialize initialize,
, applyTz applyTz,
, groupByDay groupByDay,
, listAvailMinusBusy listAvailMinusBusy,
, partitionSlots partitionSlots,
, summaryMatches summaryMatches,
, isWithin isWithin,
, addEvent addEvent
) where )
where
import ClassyPrelude.Yesod
import Control.Lens ((.~), (<&>), (^.)) import ClassyPrelude.Yesod
import Control.Monad.Logger (Loc, LogSource, LogStr, import Control.Lens ((.~), (<&>), (^.))
defaultLoc) import Control.Monad.Logger
import qualified Data.Aeson as Js ( Loc,
import Data.ByteString.Builder (toLazyByteString) LogSource,
import Data.Function ((&)) LogStr,
import qualified Data.Map as Map defaultLoc
import qualified Data.SortedList as SL )
import Data.Time.Clock (DiffTime, import qualified Data.Aeson as Js
NominalDiffTime, import Data.ByteString.Builder (toLazyByteString)
addUTCTime) import Data.Function ((&))
import Data.Time.LocalTime (LocalTime (..)) import qualified Data.Map as Map
import Data.Time.Zones (TZ, utcToLocalTimeTZ) import qualified Data.SortedList as SL
import qualified Network.Google as Google import Data.Time.Clock
import Network.Google.AppsCalendar ( DiffTime,
import qualified Network.Google.Auth as Google NominalDiffTime,
addUTCTime
)
import Data.Time.LocalTime (LocalTime (..))
import Data.Time.Zones (TZ, utcToLocalTimeTZ)
import qualified Network.Google as Google
import Network.Google.AppsCalendar
import qualified Network.Google.Auth as Google
import qualified Network.Google.Auth.ApplicationDefault as Google import qualified Network.Google.Auth.ApplicationDefault as Google
import System.Log.FastLogger (toLogStr) import System.Log.FastLogger (toLogStr)
-- | Google authorization scope representing calendar operations. -- | Google authorization scope representing calendar operations.
type CalendarScope = '[ "https://www.googleapis.com/auth/calendar"] type CalendarScope = '["https://www.googleapis.com/auth/calendar"]
-- | Credentials needed for accessing the calendar. -- | Credentials needed for accessing the calendar.
data CalendarCredentials data CalendarCredentials
...@@ -63,20 +70,24 @@ data CalendarCredentials ...@@ -63,20 +70,24 @@ data CalendarCredentials
-- | Doesn't reveal the credentials, but simply allows to distinguish -- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked. -- whether they are for Google or mocked.
instance Show CalendarCredentials where instance Show CalendarCredentials where
show MockCreds = "<mock>"
show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>" show (GoogleCreds _) = "<google>"
-- | If the field @client_id@ is just the string @"mock"@, then we use -- | If the field @client_id@ is just the string @"mock"@, then we use
-- a mock calender. Otherwise, we attempt to use @client_id@, -- a mock calender. Otherwise, we attempt to use @client_id@,
-- @client_secret@, and @refresh_token@ as Google credentials. -- @client_secret@, and @refresh_token@ as Google credentials.
instance FromJSON CalendarCredentials where instance FromJSON CalendarCredentials where
parseJSON = parseJSON =
Js.withObject "CalendarCredentials" $ \o -> Js.withObject "CalendarCredentials" $ \o ->
o .: "client_id" >>= \c -> o .: "client_id" >>= \c ->
if c == asText "mock" if c == asText "mock"
then return MockCreds then return MockCreds
else either fail (return . GoogleCreds) $ else
Google.fromJSONCredentials $ Js.encode o either fail (return . GoogleCreds)
$ Google.fromJSONCredentials
$ Js.encode o
-- | This represents a ready-to-use environment for calendar -- | This represents a ready-to-use environment for calendar
-- operations. -- operations.
...@@ -94,8 +105,8 @@ mockFreeId = "mock-free" ...@@ -94,8 +105,8 @@ mockFreeId = "mock-free"
-- calendar operations. The Google environment requires a logging -- calendar operations. The Google environment requires a logging
-- function and an HTTP manager. If using a mock calendar, a warning is -- function and an HTTP manager. If using a mock calendar, a warning is
-- printed using the logging function. -- printed using the logging function.
initialize :: initialize
(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Manager -> Manager
-> CalendarCredentials -> CalendarCredentials
-> IO CalendarContext -> IO CalendarContext
...@@ -103,69 +114,74 @@ initialize appLog _ MockCreds = do ...@@ -103,69 +114,74 @@ initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar" appLog defaultLoc "" LevelWarn "Using mock calendar"
day <- succ . utctDay <$> getCurrentTime day <- succ . utctDay <$> getCurrentTime
let free = let free =
SL.toSortedList $ SL.toSortedList
map $ map
(sampleEvent day) (sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155) [ ("free1a", fwd 0, 1100, 1155),
, ("free1b #office", fwd 0, 1300, 1450) ("free1b #office", fwd 0, 1300, 1450),
, ("free1c #office", fwd 0, 1530, 1800) ("free1c #office", fwd 0, 1530, 1800),
, ("free2a #home", fwd 1, 1200, 1600) ("free2a #home", fwd 1, 1200, 1600),
, ("free2b #office", fwd 1, 1700, 1800) ("free2b #office", fwd 1, 1700, 1800),
, ("free3a #office", fwd 2, 1000, 1200) ("free3a #office", fwd 2, 1000, 1200),
, ("free3b #home", fwd 2, 1500, 1930) ("free3b #home", fwd 2, 1500, 1930)
] ]
busy = busy =
SL.toSortedList $ SL.toSortedList
map $ map
(sampleEvent day) (sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300) [ ("busy1a", fwd 0, 1210, 1300),
, ("busy1b", fwd 0, 1330, 1430) ("busy1b", fwd 0, 1330, 1430),
, ("busy1c", fwd 0, 1500, 1550) ("busy1c", fwd 0, 1500, 1550),
, ("busy1d", fwd 0, 1730, 1830) ("busy1d", fwd 0, 1730, 1830),
, ("busy2a", fwd 1, 1130, 1215) ("busy2a", fwd 1, 1130, 1215),
, ("busy2b", fwd 1, 1330, 1400) ("busy2b", fwd 1, 1330, 1400),
, ("busy2c", fwd 1, 1430, 1500) ("busy2c", fwd 1, 1430, 1500),
, ("busy2d", fwd 1, 1610, 1650) ("busy2d", fwd 1, 1610, 1650),
, ("busy3a", fwd 2, 1100, 1400)