Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
B
bookme
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Christopher League
bookme
Commits
cea30e2e
Commit
cea30e2e
authored
Jun 06, 2018
by
Christopher League
🖥
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Remove header debugging in VersionR; run hfmt -w
parent
3fba4846
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
54 additions
and
47 deletions
+54
-47
src/BookingForm.hs
src/BookingForm.hs
+9
-7
src/Calendar.hs
src/Calendar.hs
+0
-1
src/Handlers.hs
src/Handlers.hs
+20
-16
src/QueryForm.hs
src/QueryForm.hs
+16
-14
src/Settings.hs
src/Settings.hs
+9
-9
No files found.
src/BookingForm.hs
View file @
cea30e2e
...
...
@@ -55,8 +55,7 @@ fromSession :: Handler Booking
fromSession
=
runMaybeT
fromSessionMaybe
>>=
maybe
QF
.
noSessionError
return
bfs
::
Text
->
String
->
FieldSettings
site
bfs
label
help
=
(
B3
.
bfs
label
)
{
fsTooltip
=
Just
(
fromString
help
)}
bfs
label
help
=
(
B3
.
bfs
label
)
{
fsTooltip
=
Just
(
fromString
help
)}
bookingAForm
::
Maybe
Booking
->
AForm
Handler
Booking
bookingAForm
bOpt
=
...
...
@@ -66,9 +65,10 @@ bookingAForm bOpt =
aopt
textField
contact
(
bookContact
<$>
bOpt
)
<*
B3
.
bootstrapSubmit
(
"Submit"
::
B3
.
BootstrapSubmit
Text
)
where
name
=
bfs
"*Name"
"Who are you?"
email
=
bfs
"*Email"
"You must use a valid email address"
subject
=
bfs
"*Subject"
"What course are you in? What do you want to talk about?"
name
=
bfs
"*Name"
"Who are you?"
email
=
bfs
"*Email"
"You must use a valid email address"
subject
=
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?"
horizOffset
::
B3
.
BootstrapGridOptions
...
...
@@ -88,10 +88,12 @@ 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
=
B3
.
BootstrapHorizontalForm
horizOffset
labelSize
horizOffset
inputSize
horiz
=
B3
.
BootstrapHorizontalForm
horizOffset
labelSize
horizOffset
inputSize
eventFromBooking
::
Booking
->
QF
.
QueryForm
->
QF
.
TimeSlot
->
SimpleEventUTC
eventFromBooking
Booking
{
..
}
QF
.
QueryForm
{
..
}
slot
=
SimpleEvent
{
..
}
...
...
src/Calendar.hs
View file @
cea30e2e
...
...
@@ -261,7 +261,6 @@ listUpcoming (GoogleCxt env) cid lookahead = do
-- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
-- sayEvent prefix SimpleEvent {..} =
-- say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary
-- | Convert an event into a local time zone.
applyTz
::
TZ
->
SimpleEventUTC
->
SimpleEventLocal
applyTz
tz
ev
=
...
...
src/Handlers.hs
View file @
cea30e2e
...
...
@@ -24,16 +24,15 @@ module Handlers
,
getVersionR
)
where
import
BookingForm
(
b3Class
,
inputSize
,
labelSize
)
import
qualified
BookingForm
as
BF
import
BookingForm
(
b3Class
,
inputSize
,
labelSize
)
import
Calendar
import
Control.Monad.Trans.Maybe
import
Data.FileEmbed
(
embedFile
)
import
qualified
Data.SortedList
as
SL
import
Data.Time.Clock
(
getCurrentTime
,
addUTC
Time
)
import
qualified
Network.Wai
import
Data.Time.Clock
(
addUTCTime
,
getCurrent
Time
)
import
Data.Time.Zones
(
localTimeToUTCTZ
,
utcToLocalTimeTZ
)
import
Development.GitRev
import
Data.Time.Zones
(
localTimeToUTCTZ
,
utcToLocalTimeTZ
)
import
qualified
FreshCache
as
FC
import
Import
import
qualified
QueryForm
as
QF
...
...
@@ -69,9 +68,7 @@ formSuccess ((formResult, _), _) =
getAvailR
::
Handler
Html
getAvailR
=
do
QF
.
QueryForm
{
..
}
<-
formSuccess
=<<
runFormGet
(
QF
.
queryForm
""
Nothing
)
App
{
appSettings
=
AppSettings
{
..
}
,
appCalendarCache
}
<-
getYesod
App
{
appSettings
=
AppSettings
{
..
},
appCalendarCache
}
<-
getYesod
earliest
<-
addUTCTime
appLeadTime
<$>
liftIO
getCurrentTime
daysWithSlots
<-
groupByDay
.
...
...
@@ -99,12 +96,14 @@ getBookR = do
showWhenWhere
::
Handler
(
QF
.
QueryForm
,
QF
.
TimeSlot
,
Widget
)
showWhenWhere
=
do
AppSettings
{
appDefaultTimeZone
}
<-
appSettings
<$>
getYesod
AppSettings
{
appDefaultTimeZone
}
<-
appSettings
<$>
getYesod
(
q
@
QF
.
QueryForm
{
..
},
s
@
QF
.
TimeSlot
{
..
})
<-
QF
.
fromSessionWithSlot
let
inOtherZone
=
if
queryTzLabel
==
appDefaultTimeZone
then
Nothing
else
Just
$
utcToLocalTimeTZ
(
tzByLabel
appDefaultTimeZone
)
$
localTimeToUTCTZ
(
tzByLabel
queryTzLabel
)
slotLocal
if
queryTzLabel
==
appDefaultTimeZone
then
Nothing
else
Just
$
utcToLocalTimeTZ
(
tzByLabel
appDefaultTimeZone
)
$
localTimeToUTCTZ
(
tzByLabel
queryTzLabel
)
slotLocal
return
(
q
,
s
,
$
(
widgetFile
"when-where"
))
postBookR
::
Handler
Html
...
...
@@ -129,7 +128,7 @@ postBookR = do
getFinalR
::
Handler
Html
getFinalR
=
do
(
QF
.
QueryForm
{
..
},
QF
.
TimeSlot
{
..
},
whenWhere
)
<-
showWhenWhere
BF
.
Booking
{
..
}
<-
BF
.
fromSession
BF
.
Booking
{
..
}
<-
BF
.
fromSession
defaultLayout
$
(
widgetFile
"final"
)
getClearR
::
Handler
Html
...
...
@@ -148,7 +147,12 @@ getRobotsR =
return
$
TypedContent
typePlain
$
toContent
$
(
embedFile
"config/robots.txt"
)
getVersionR
::
Handler
Text
getVersionR
=
do
req
<-
reqWaiRequest
<$>
getRequest
let
hs
=
foldMap
(
\
(
h
,
v
)
->
tshow
h
<>
": "
<>
tshow
v
<>
"
\n
"
)
$
Network
.
Wai
.
requestHeaders
req
return
$
hs
<>
"
\n
"
<>
$
(
gitHash
)
<>
if
$
(
gitDirty
)
then
"+"
else
""
getVersionR
-- req <- reqWaiRequest <$> getRequest
-- let hs = foldMap (\(h,v) -> tshow h <> ": " <> tshow v <> "\n") $ Network.Wai.requestHeaders req
=
do
return
$
$
(
gitHash
)
<>
if
$
(
gitDirty
)
then
"+"
else
""
src/QueryForm.hs
View file @
cea30e2e
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
...
...
@@ -40,10 +40,10 @@ module QueryForm
)
where
import
Control.Monad.Trans.Maybe
import
qualified
Data.Map
as
Map
import
qualified
Data.Time.Format
as
TF
import
Data.Time.LocalTime
(
LocalTime
)
import
Import
import
qualified
Data.Map
as
Map
import
Text.Blaze
(
ToMarkup
(
..
))
import
Text.Julius
(
RawJS
(
..
),
ToJavascript
(
..
))
...
...
@@ -215,7 +215,7 @@ prettyTz' = concatMap tzChars
where
tzChars
'_'
=
" "
tzChars
'/'
=
" » "
tzChars
c
=
singleton
c
tzChars
c
=
singleton
c
prettyTz
::
TZLabelW
->
Text
prettyTz
=
prettyTz'
.
toPathPiece
...
...
@@ -225,16 +225,15 @@ zonesByContinent =
Map
.
fromList
$
map
continent
$
groupAllOn
fst
$
map
splitTz
allZones
where
allZones
::
[
TZLabelW
]
allZones
=
[
minBound
..
maxBound
]
allZones
=
[
minBound
..
maxBound
]
splitTz
::
TZLabelW
->
(
Text
,
(
Text
,
Text
))
splitTz
tz
=
(
cont
,
(
txt
,
prettyTz'
(
drop
1
city
)))
where
(
cont
,
city
)
=
break
(
==
'/'
)
txt
txt
=
toPathPiece
tz
continent
::
[(
Text
,
a
)]
->
(
Text
,
[
a
])
continent
[]
=
error
"zonesByContinent: Impossible"
continent
((
x
,
y
)
:
xys
)
=
(
x
,
y
:
map
snd
xys
)
where
(
cont
,
city
)
=
break
(
==
'/'
)
txt
txt
=
toPathPiece
tz
continent
::
[(
Text
,
a
)]
->
(
Text
,
[
a
])
continent
[]
=
error
"zonesByContinent: Impossible"
continent
((
x
,
y
)
:
xys
)
=
(
x
,
y
:
map
snd
xys
)
-- | Present time zone choices.
tzSelectorField
::
Text
->
Field
Handler
TZLabelW
...
...
@@ -242,9 +241,9 @@ tzSelectorField idReset = Field {..}
where
fieldEnctype
=
UrlEncoded
fieldParse
(
txt
:
_
)
_
=
return
$
Right
$
fromPathPiece
txt
fieldParse
_
_
=
return
$
Left
$
SomeMessage
$
MsgInvalidEntry
"Timezone"
fieldParse
_
_
=
return
$
Left
$
SomeMessage
$
MsgInvalidEntry
"Timezone"
fieldView
_
name
attrs
val
_
=
do
AppSettings
{
appDefaultTimeZone
}
<-
appSettings
<$>
getYesod
AppSettings
{
appDefaultTimeZone
}
<-
appSettings
<$>
getYesod
(
idShowDefaultTz
,
idTextTz
,
idSelectTz
)
<-
newIdent3
let
currentTz
=
toPathPiece
$
either
(
const
appDefaultTimeZone
)
id
val
isDefaultTz
=
currentTz
==
toPathPiece
appDefaultTimeZone
...
...
@@ -256,7 +255,10 @@ qControl = "qcontrol"
-- | The complete query form for the front page.
queryForm
::
Text
->
Maybe
QueryForm
->
Html
->
MForm
Handler
(
FormResult
QueryForm
,
Widget
)
Text
->
Maybe
QueryForm
->
Html
->
MForm
Handler
(
FormResult
QueryForm
,
Widget
)
queryForm
idReset
qOpt
extra
=
do
AppSettings
{
..
}
<-
appSettings
<$>
getYesod
let
qs
n
=
""
{
fsName
=
Just
(
qiName
n
),
fsAttrs
=
[(
"class"
,
qControl
)]}
...
...
src/Settings.hs
View file @
cea30e2e
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: Settings
...
...
@@ -111,9 +111,9 @@ data AppSettings = AppSettings
-- ^ Valid lengths of appointments, in minutes
,
appCacheExpiry
::
NominalDiffTime
-- ^ Cached calendar data older than this will be refreshed
,
appProviderName
::
Maybe
Text
,
appProviderName
::
Maybe
Text
-- ^ Name of person/service providing appointments
,
appProviderAvatar
::
Maybe
Text
,
appProviderAvatar
::
Maybe
Text
-- ^ URL to image of person/service providing appointments
}
...
...
@@ -158,7 +158,7 @@ instance FromJSON AppSettings where
appFreeCalendarId
<-
o
.:
"free-calendar"
appBusyCalendarId
<-
o
.:
"busy-calendar"
appLookaheadWeeks
<-
o
.:
"look-ahead-weeks"
appLeadTime
<-
(
*
60
)
<$>
(
o
.:
"lead-time-minutes"
)
appLeadTime
<-
(
*
60
)
<$>
(
o
.:
"lead-time-minutes"
)
appApptLengthsMinutes
<-
o
.:
"appointment-lengths-minutes"
appProviderName
<-
o
.:?
"provider-name"
appProviderAvatar
<-
o
.:?
"provider-avatar"
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment