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
31d061c1
Commit
31d061c1
authored
Jun 02, 2018
by
Christopher League
Browse files
Time zone selector
parent
b5ab674f
Changes
7
Hide whitespace changes
Inline
Side-by-side
config/routes
View file @
31d061c1
...
...
@@ -10,3 +10,4 @@
/avail AvailR GET
/book BookR GET POST
/final FinalR GET
/clear ClearR GET
src/Calendar.hs
View file @
31d061c1
...
...
@@ -255,7 +255,7 @@ listUpcoming (GoogleCxt env) cid lookahead = do
Google
.
runGoogle
env
$
Google
.
send
$
eventsList
cid
&
elTimeMin
.~
Just
now
&
elTimeMax
.~
Just
end
let
es
=
SL
.
toSortedList
$
mapMaybe
simplifyEvent
$
xs
^.
eveItems
forM_
(
SL
.
fromSortedList
es
)
$
sayEvent
$
take
4
cid
--
forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
return
es
sayEvent
::
MonadIO
m
=>
Text
->
SimpleEventUTC
->
m
()
...
...
@@ -320,7 +320,7 @@ listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
availT
<-
async
$
listUpcoming
cxt
cidAvail
lookahead
busyT
<-
async
$
listUpcoming
cxt
cidBusy
(
lookahead
+
86400
)
es
<-
availMinusBusy
<$>
waitAsync
availT
<*>
waitAsync
busyT
forM_
(
SL
.
fromSortedList
es
)
$
sayEvent
"DIFF"
--
forM_ (SL.fromSortedList es) $ sayEvent "DIFF"
return
es
-- | Take a stream of available times and split them into slots exactly
...
...
src/Handlers.hs
View file @
31d061c1
...
...
@@ -20,6 +20,7 @@ module Handlers
,
getBookR
,
postBookR
,
getFinalR
,
getClearR
)
where
import
qualified
BookingForm
as
BF
...
...
@@ -116,6 +117,9 @@ getFinalR = do
<p>#{tshow b}
|]
getClearR
::
Handler
Html
getClearR
=
clearSession
>>
redirect
HomeR
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR
::
Handler
TypedContent
...
...
src/QueryForm.hs
View file @
31d061c1
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
...
...
@@ -41,6 +42,7 @@ import Control.Monad.Trans.Maybe
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
(
..
))
...
...
@@ -207,13 +209,51 @@ locationChoiceField = Field {..}
locs
<-
appLocations
.
appSettings
<$>
getYesod
$
(
widgetFile
"query-locations"
)
zonesByContinent
=
Map
.
fromList
$
map
continent
$
groupAllOn
fst
$
map
splitTz
allZones
where
allZones
::
[
TZLabelW
]
allZones
=
[
minBound
..
maxBound
]
splitTz
::
TZLabelW
->
(
Text
,
Text
)
splitTz
=
(
id
***
drop
1
)
.
break
(
==
'/'
)
.
toPathPiece
continent
::
[(
Text
,
Text
)]
->
(
Text
,[
Text
])
continent
[]
=
error
"zonesByContinent: Impossible"
continent
((
x
,
y
)
:
xys
)
=
(
x
,
y
:
map
snd
xys
)
-- | Present time zone choices.
tzSelectorField
::
Field
Handler
TZLabelW
tzSelectorField
=
Field
{
..
}
where
fieldEnctype
=
UrlEncoded
fieldParse
(
txt
:
_
)
_
=
return
$
Right
$
fromPathPiece
txt
fieldParse
_
_
=
return
$
Left
$
SomeMessage
$
MsgInvalidEntry
"Timezone"
fieldView
i
name
attrs
val
req
=
do
AppSettings
{
appDefaultTimeZone
}
<-
appSettings
<$>
getYesod
let
currentTz
=
toPathPiece
$
either
(
const
appDefaultTimeZone
)
id
val
cityAttrs
=
[(
asText
"class"
,
"tzsel "
<>
qControl
)]
[
whamlet
|
<input type=hidden name=#{name} value=#{currentTz}>
<select name=#{name}-con *{attrs}>
$forall c <- Map.keys zonesByContinent
<option value=#{c} :isPrefixOf c currentTz:selected>#{c}
$forall c <- Map.keys zonesByContinent
<select name=#{name}-#{c} :not(isPrefixOf c currentTz):style="display:none" *{cityAttrs}>
$maybe xs <- lookup c zonesByContinent
$forall x <- xs
<option value=#{x} :isSuffixOf x currentTz:selected>#{x}
|]
qControl
::
Text
qControl
=
"qcontrol"
-- | The complete query form for the front page.
queryForm
::
Maybe
QueryForm
->
Html
->
MForm
Handler
(
FormResult
QueryForm
,
Widget
)
queryForm
qOpt
extra
=
do
AppSettings
{
..
}
<-
appSettings
<$>
getYesod
qc
<-
newIdent
let
qs
n
=
""
{
fsName
=
Just
(
qiName
n
),
fsAttrs
=
[(
"class"
,
qc
)]}
let
qs
n
=
""
{
fsName
=
Just
(
qiName
n
),
fsAttrs
=
[(
"class"
,
qControl
)]}
(
lenRes
,
lenView
)
<-
mreq
(
selectField
apptLengthOptions
)
...
...
@@ -229,9 +269,9 @@ queryForm qOpt extra = do
locationChoiceField
(
qs
idLocation
)
(
queryLocation
<$>
qOpt
<|>
headMay
appLocations
)
(
tzRes
,
_
)
<-
(
tzRes
,
tzView
)
<-
mreq
hidden
Field
tzSelector
Field
(
qs
idTzLabel
)
(
queryTzLabel
<$>
qOpt
<|>
Just
appDefaultTimeZone
)
return
...
...
src/Settings.hs
View file @
31d061c1
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
...
...
@@ -113,7 +114,7 @@ data AppSettings = AppSettings
-- | Wrap a time zone label, so we can specify type classes.
newtype
TZLabelW
=
TZLabelW
{
unwrapTZLabel
::
TZLabel
}
deriving
(
Eq
,
Show
)
}
deriving
(
Eq
,
Show
,
Bounded
,
Enum
)
-- | Look up the time zone spec for given label.
tzByLabel
::
TZLabelW
->
TZ
...
...
templates/query-form.hamlet
View file @
31d061c1
...
...
@@ -4,9 +4,12 @@
^{fvInput lenView}
meeting times using
^{fvInput fmtView}
notation in
#{toPathPiece appDefaultTimeZone}
<input #tz .qc name=tz type=hidden
value=#{toPathPiece appDefaultTimeZone}>
time zone:
notation
<p>
for the time zone
^{fvInput tzView}
<a href=@{ClearR}>(Reset to defaults)</a>
<p>
^{fvInput locView}
templates/query-form.julius
View file @
31d061c1
$(function(){
$(".#{rawJS q
c
}").change(
sendQuery
);
$(".#{rawJS q
Control
}").change(
juggleTimeZone
);
sendQuery();
});
function juggleTimeZone() {
if($(this).hasClass("tzsel") || $(this).attr("name") == "tz-con") {
var continent = $("select[name=tz-con]").val();
var citySel = "select[name=tz-"+continent+"]";
$(".tzsel").hide();
$(citySel).show();
$("input[name=tz]").val(continent + "/" + $(citySel).val());
}
sendQuery();
}
function gatherQueryParams() {
return $.param({
_hasdata: 1,
...
...
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