Skip to content

GitLab

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
Hide whitespace changes
Inline Side-by-side
src/Application.hs
View file @ d55a1be9
{-# 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)
......
src/BookingForm.hs
View file @ d55a1be9
{-# 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 =
......
src/Calendar.hs
View file @ d55a1be9
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module: Calendar
......@@ -14,46 +14,53 @@ calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging.
-}
module Calendar
( CalendarScope
, CalendarCredentials
, CalendarContext
, CalendarId
, SimpleEvent(..)
, SimpleEventUTC
, SimpleEventLocal
, Attendee(..)
, initialize
, applyTz
, groupByDay
, listAvailMinusBusy
, partitionSlots
, summaryMatches
, isWithin
, addEvent
) where
import ClassyPrelude.Yesod
import Control.Lens ((.~), (<&>), (^.))
import Control.Monad.Logger (Loc, LogSource, LogStr,
defaultLoc)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Data.Function ((&))
import qualified Data.Map as Map
import qualified Data.SortedList as SL
import Data.Time.Clock (DiffTime,
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
( CalendarScope,
CalendarCredentials,
CalendarContext,
CalendarId,
SimpleEvent (..),
SimpleEventUTC,
SimpleEventLocal,
Attendee (..),
initialize,
applyTz,
groupByDay,
listAvailMinusBusy,
partitionSlots,
summaryMatches,
isWithin,
addEvent
)
where
import ClassyPrelude.Yesod
import Control.Lens ((.~), (<&>), (^.))
import Control.Monad.Logger
( Loc,
LogSource,
LogStr,
defaultLoc
)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Data.Function ((&))
import qualified Data.Map as Map
import qualified Data.SortedList as SL
import Data.Time.Clock
( DiffTime,
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 System.Log.FastLogger (toLogStr)
import System.Log.FastLogger (toLogStr)
-- | 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.
data CalendarCredentials
......@@ -63,20 +70,24 @@ data CalendarCredentials
-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
instance Show CalendarCredentials where
show MockCreds = "<mock>"
show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>"
-- | If the field @client_id@ is just the string @"mock"@, then we use
-- a mock calender. Otherwise, we attempt to use @client_id@,
-- @client_secret@, and @refresh_token@ as Google credentials.
instance FromJSON CalendarCredentials where
parseJSON =
Js.withObject "CalendarCredentials" $ \o ->
o .: "client_id" >>= \c ->
if c == asText "mock"
then return MockCreds
else either fail (return . GoogleCreds) $
Google.fromJSONCredentials $ Js.encode o
else
either fail (return . GoogleCreds)
$ Google.fromJSONCredentials
$ Js.encode o
-- | This represents a ready-to-use environment for calendar
-- operations.
......@@ -94,8 +105,8 @@ mockFreeId = "mock-free"
-- calendar operations. The Google environment requires a logging
-- function and an HTTP manager. If using a mock calendar, a warning is
-- printed using the logging function.
initialize ::
(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
initialize
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Manager
-> CalendarCredentials
-> IO CalendarContext
......@@ -103,69 +114,74 @@ initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar"
day <- succ . utctDay <$> getCurrentTime
let free =
SL.toSortedList $
map
(sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155)
, ("free1b #office", fwd 0, 1300, 1450)
, ("free1c #office", fwd 0, 1530, 1800)
, ("free2a #home", fwd 1, 1200, 1600)
, ("free2b #office", fwd 1, 1700, 1800)
, ("free3a #office", fwd 2, 1000, 1200)
, ("free3b #home", fwd 2, 1500, 1930)
]
SL.toSortedList
$ map
(sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155),
("free1b #office", fwd 0, 1300, 1450),
("free1c #office", fwd 0, 1530, 1800),
("free2a #home", fwd 1, 1200, 1600),
("free2b #office", fwd 1, 1700, 1800),
("free3a #office", fwd 2, 1000, 1200),
("free3b #home", fwd 2, 1500, 1930)
]
busy =
SL.toSortedList $
map
(sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300)
, ("busy1b", fwd 0, 1330, 1430)
, ("busy1c", fwd 0, 1500, 1550)
, ("busy1d", fwd 0, 1730, 1830)
, ("busy2a", fwd 1, 1130, 1215)
, ("busy2b", fwd 1, 1330, 1400)
, ("busy2c", fwd 1, 1430, 1500)
, ("busy2d", fwd 1, 1610, 1650)
, ("busy3a", fwd 2, 1100, 1400)
, ("busy3b", fwd 2, 1900, 2100)
]
SL.toSortedList
$ map
(sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300),
("busy1b", fwd 0, 1330, 1430),
("busy1c", fwd 0, 1500, 1550),
("busy1d", fwd 0, 1730, 1830),
("busy2a", fwd 1, 1130, 1215),
("busy2b", fwd 1, 1330, 1400),
("busy2c", fwd 1, 1430, 1500),
("busy2d", fwd 1, 1610, 1650),
("busy3a", fwd 2, 1100, 1400),
("busy3b", fwd 2, 1900, 2100)
]
MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)])
initialize appLog manager (GoogleCreds creds) =
GoogleCxt <$>
(Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
GoogleCxt
<$> (Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
where
gooLog level builder =
appLog defaultLoc "" lv (toLogStr (toLazyByteString builder))
where
lv =
case level of
Google.Info -> LevelInfo
Google.Info -> LevelInfo
Google.Error -> LevelError
Google.Debug -> LevelDebug
Google.Trace -> LevelOther "trace"
-- | A record containing just the essential event data, abstracted over
-- the type of the time-stamp.
data SimpleEvent t = SimpleEvent
{ seSummary :: Text
, seStart :: t
, seEnd :: t
, seDescr :: Text
, seLocation :: Text
, seAttendees :: [Attendee]
} deriving (Eq, Show)
data SimpleEvent t
= SimpleEvent
{ seSummary :: Text,
seStart :: t,
seEnd :: t,
seDescr :: Text,
seLocation :: Text,
seAttendees :: [Attendee]
}
deriving (Eq, Show)
instance Ord t => Ord (SimpleEvent t) where
compare x y = compare (seStart x) (seStart y)
type SimpleEventUTC = SimpleEvent UTCTime
type SimpleEventLocal = SimpleEvent LocalTime
data Attendee = Attendee
{ atName :: Text
, atEmail :: Text
} deriving (Show, Eq)
data Attendee
= Attendee
{ atName :: Text,
atEmail :: Text
}
deriving (Show, Eq)
-- | Extract essential event data from a Google @Event@ object.
simplifyEvent :: Event -> Maybe SimpleEventUTC
......@@ -180,22 +196,29 @@ simplifyEvent e = do
expandEvent :: SimpleEventUTC -> Event
expandEvent SimpleEvent {..} =
<