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
......@@ -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 =
......
......@@ -14,36 +14,43 @@ 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
( 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 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,
import Data.Time.Clock
( DiffTime,
NominalDiffTime,
addUTCTime)
addUTCTime
)
import Data.Time.LocalTime (LocalTime (..))
import Data.Time.Zones (TZ, utcToLocalTimeTZ)
import qualified Network.Google as Google
......@@ -53,7 +60,7 @@ import qualified Network.Google.Auth.ApplicationDefault as Google
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,6 +70,7 @@ 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 (GoogleCreds _) = "<google>"
......@@ -70,13 +78,16 @@ instance Show CalendarCredentials where
-- 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,36 +114,36 @@ initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar"
day <- succ . utctDay <$> getCurrentTime
let free =
SL.toSortedList $
map
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)
[ ("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
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)
[ ("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))
......@@ -146,26 +157,31 @@ initialize appLog manager (GoogleCreds creds) =
-- | 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,21 +196,28 @@ simplifyEvent e = do
expandEvent :: SimpleEventUTC -> Event
expandEvent SimpleEvent {..} =
event & eSummary .~ Just seSummary &
eStart .~ Just (eventDateTime & edtDateTime .~ Just seStart) &
eEnd .~ Just (eventDateTime & edtDateTime .~ Just seEnd) &
eDescription .~ Just seDescr &
eLocation .~ Just seLocation &
eAttendees .~ map expandAttendee seAttendees &
eReminders .~
Just
(eventReminders & erOverrides .~ defaultReminders &
erUseDefault .~ Just False)
event & eSummary .~ Just seSummary
& eStart
.~ Just (eventDateTime & edtDateTime .~ Just seStart)
& eEnd
.~ Just (eventDateTime & edtDateTime .~ Just seEnd)
& eDescription
.~ Just seDescr
& eLocation
.~ Just seLocation
& eAttendees
.~ map expandAttendee seAttendees
& eReminders
.~ Just
( eventReminders & erOverrides .~ defaultReminders
& erUseDefault
.~ Just False
)
defaultReminders :: [EventReminder]
defaultReminders =
[ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440
, eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
[ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440,
eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
]
simplifyAttendee :: EventAttendee -> Maybe Attendee
......@@ -231,17 +254,17 @@ toSec hmm = fromInteger $ h * 3600 + m * 60
sampleEvent :: Day -> (Text, Day -> Day, Int, Int) -> SimpleEventUTC
sampleEvent d (summary, f, hmm1, hmm2) =
SimpleEvent
{ seSummary = summary
, seStart = UTCTime (f d) (toSec hmm1)
, seEnd = UTCTime (f d) (toSec hmm2)
, seDescr = ""
, seLocation = ""
, seAttendees = []
{ seSummary = summary,
seStart = UTCTime (f d) (toSec hmm1),
seEnd = UTCTime (f d) (toSec hmm2),
seDescr = "",
seLocation = "",
seAttendees = []
}
-- | Fetch events from a single calendar.
listUpcoming ::
MonadResource m
listUpcoming
:: MonadResource m
=> CalendarContext
-> CalendarId
-> NominalDiffTime -- ^How far to look ahead
......@@ -252,9 +275,15 @@ listUpcoming (GoogleCxt env) cid lookahead = do
now <- liftIO getCurrentTime
let end = addUTCTime lookahead now
xs <-
Google.runGoogle env $
Google.send $ eventsList cid & elTimeMin .~ Just now & elTimeMax .~ Just end
& elSingleEvents .~ Just True
Google.runGoogle env
$ Google.send
$ eventsList cid
& elTimeMin
.~ Just now
& elTimeMax
.~ Just end
& elSingleEvents
.~ Just True
let es = SL.toSortedList $ mapMaybe simplifyEvent $ xs ^. eveItems
--forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
return es
......@@ -266,8 +295,8 @@ listUpcoming (GoogleCxt env) cid lookahead = do
applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
applyTz tz ev =
ev
{ seStart = utcToLocalTimeTZ tz (seStart ev)
, seEnd = utcToLocalTimeTZ tz (seEnd ev)
{ seStart = utcToLocalTimeTZ tz (seStart ev),
seEnd = utcToLocalTimeTZ tz (seEnd ev)
}
groupByDay :: SL.SortedList SimpleEventLocal -> [[SimpleEventLocal]]
......@@ -276,8 +305,8 @@ groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList
-- | Construct a stream of events that represent available times with
-- chunks of busy times removed. Requires that the event streams are
-- already ordered.
availMinusBusy ::
Ord t
availMinusBusy
:: Ord t
=> SL.SortedList (SimpleEvent t) -- ^Available times
-> SL.SortedList (SimpleEvent t) -- ^Busy times
-> SL.SortedList (SimpleEvent t) -- ^Remaining available times
......@@ -302,15 +331,14 @@ availMinusBusy aaa bbb =
let a' = a {seStart = seEnd b}
in availMinusBusy (SL.insert a' aa) bb
-- B overlaps end of A, so keep truncated A and consider next A
| otherwise {-seStart a <= seStart b && seEnd a <= seEnd b-}
->
| otherwise -> {-seStart a <= seStart b && seEnd a <= seEnd b-}
let a' = a {seEnd = seStart b}
in SL.insert a' $ availMinusBusy aa bbb
-- | Simultaneously fetch two calendars and return the difference
-- between them.
listAvailMinusBusy ::
(MonadResource m, MonadUnliftIO m)
listAvailMinusBusy
:: (MonadResource m, MonadUnliftIO m)
=> CalendarContext
-> CalendarId -- ^Calendar with available times
-> CalendarId -- ^Calendar with busy times
......@@ -325,8 +353,8 @@ listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
-- | Take a stream of available times and split them into slots exactly
-- N minutes long.
partitionSlots ::
Maybe Int -- ^ Offset of each new slot, in minutes
partitionSlots
:: Maybe Int -- ^ Offset of each new slot, in minutes
-> Int -- ^ Length of each slot, in minutes
-> SL.SortedList SimpleEventUTC
-> SL.SortedList SimpleEventUTC
......@@ -341,8 +369,10 @@ partitionSlots offsetM lengthM evs = loop evs
let thisEnd = addUTCTime lengthT (seStart e)
nextStart = addUTCTime offsetT (seStart e)
in if thisEnd <= seEnd e
then SL.insert e {seEnd = thisEnd} $
loop $ SL.insert e {seStart = nextStart} es
then
SL.insert e {seEnd = thisEnd}
$ loop
$ SL.insert e {seStart = nextStart} es
else loop es
summaryMatches :: Text -> SimpleEvent t -> Bool