Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Christopher League
bookme
Commits
d55a1be9
Commit
d55a1be9
authored
Aug 19, 2019
by
Christopher League
Browse files
ormolu formatting
parent
1b3f7ba0
Pipeline
#831
passed with stage
in 2 minutes and 12 seconds
Changes
12
Pipelines
1
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