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
bdb06417
Commit
bdb06417
authored
Jun 02, 2018
by
Christopher League
Browse files
Clean up and simplify
parent
31d061c1
Changes
7
Hide whitespace changes
Inline
Side-by-side
package.yaml
View file @
bdb06417
...
...
@@ -7,51 +7,48 @@ dependencies:
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
-
base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
-
aeson >=0.6 && <1.3
-
bytestring >=0.9 && <0.11
-
case-insensitive
-
classy-prelude >=1.4 && <1.5
-
classy-prelude-conduit >=1.4 && <1.5
-
classy-prelude-yesod >=1.4 && <1.5
-
conduit >=1.0 && <2.0
-
containers
-
base64-bytestring
-
binary
-
data-default
-
directory >=1.1 && <1.4
-
exceptions
-
fast-logger >=2.2 && <2.5
-
file-embed
-
foreign-store
-
gogol >=0.3.0 && <0.4
-
gogol-apps-calendar >=0.3.0 && <0.4
-
hjsmin >=0.1 && <0.3
-
http-client-tls >=0.3 && <0.4
-
http-conduit >=2.3 && <2.4
-
http-types
-
lens
-
monad-control >=0.3 && <1.1
-
monad-logger >=0.3 && <0.4
-
safe
-
shakespeare >=2.0 && <2.1
-
sorted-list >=0.2.0.0 && <0.3
-
template-haskell
-
text >=0.11 && <2.0
-
time
-
tz
-
transformers
-
blaze-markup
-
unordered-containers
-
vector
-
wai
-
wai-extra >=3.0 && <3.1
-
wai-logger >=2.2 && <2.4
-
warp >=3.0 && <3.3
-
yaml >=0.8 && <0.9
-
yesod >=1.6 && <1.7
-
yesod-core >=1.6 && <1.7
-
yesod-form >=1.6 && <1.7
-
yesod-static >=1.6 && <1.7
-
aeson >=0.6 && <1.3
-
blaze-markup >=0.8.2.1 && <0.9
-
bytestring >=0.9 && <0.11
-
case-insensitive >=1.2.0.11 && <1.3
-
classy-prelude >=1.4 && <1.5
-
classy-prelude-conduit >=1.4 && <1.5
-
classy-prelude-yesod >=1.4 && <1.5
-
conduit >=1.0 && <2.0
-
containers >=0.5.10.2 && <0.6
-
data-default >=0.7.1.1 && <0.8
-
directory >=1.1 && <1.4
-
exceptions >=0.8.3 && <0.9
-
fast-logger >=2.2 && <2.5
-
file-embed >=0.0.10.1 && <0.1
-
foreign-store >=0.2 && <0.3
-
gogol >=0.3.0 && <0.4
-
gogol-apps-calendar >=0.3.0 && <0.4
-
hjsmin >=0.1 && <0.3
-
http-client-tls >=0.3 && <0.4
-
http-conduit >=2.3 && <2.4
-
http-types >=0.12.1 && <0.13
-
lens >=4.16.1 && <4.17
-
monad-control >=0.3 && <1.1
-
monad-logger >=0.3 && <0.4
-
shakespeare >=2.0 && <2.1
-
sorted-list >=0.2.0.0 && <0.3
-
template-haskell >=2.12.0.0 && <2.13
-
text >=0.11 && <2.0
-
time >=1.8.0.2 && <1.9
-
transformers >=0.5.2.0 && <0.6
-
tz >=0.1.3.1 && <0.2
-
unordered-containers >=0.2.9.0 && <0.3
-
vector >=0.12.0.1 && <0.13
-
wai >=3.2.1.2 && <3.3
-
wai-extra >=3.0 && <3.1
-
wai-logger >=2.2 && <2.4
-
warp >=3.0 && <3.3
-
yaml >=0.8 && <0.9
-
yesod >=1.6 && <1.7
-
yesod-core >=1.6 && <1.7
-
yesod-form >=1.6 && <1.7
-
yesod-static >=1.6 && <1.7
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.
...
...
src/Calendar.hs
View file @
bdb06417
...
...
@@ -258,9 +258,9 @@ listUpcoming (GoogleCxt env) cid lookahead = do
--forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
return
es
sayEvent
::
MonadIO
m
=>
Text
->
SimpleEventUTC
->
m
()
sayEvent
prefix
SimpleEvent
{
..
}
=
say
$
prefix
<>
" "
<>
tshow
seStart
<>
" "
<>
tshow
seEnd
<>
" "
<>
seSummary
--
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
...
...
src/Handler/Common.hs
deleted
100644 → 0
View file @
31d061c1
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions.
module
Handler.Common
where
import
Data.FileEmbed
(
embedFile
)
import
Import
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR
::
Handler
TypedContent
getFaviconR
=
do
cacheSeconds
$
60
*
60
*
24
*
30
-- cache for a month
return
$
TypedContent
"image/x-icon"
$
toContent
$
(
embedFile
"config/favicon.ico"
)
getRobotsR
::
Handler
TypedContent
getRobotsR
=
return
$
TypedContent
typePlain
$
toContent
$
(
embedFile
"config/robots.txt"
)
src/Handler/Home.hs
deleted
100644 → 0
View file @
31d061c1
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module
Handler.Home
where
import
qualified
BookingForm
as
BF
import
Calendar
import
qualified
Data.SortedList
as
SL
import
Data.Time.Clock
(
addUTCTime
)
import
Data.Time.Zones
import
qualified
FreshCache
as
FC
import
Import
import
qualified
QueryForm
as
QF
import
Text.Hamlet
(
hamletFile
)
import
Text.Julius
(
RawJS
(
..
))
{-
getHomeR :: Handler Html
getHomeR = do
App {..} <- getYesod
-- Start refresh of calendar, but don't wait for result.
void $ async $ FC.readCache appCalendarCache
(widget, enctype) <- generateFormPost QF.queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout $ do
setTitle "Book an appointment"
$(widgetFile "homepage")
formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
formSuccess ((formResult, _), _) =
case formResult of
FormMissing -> invalidArgs ["Missing form data!"]
FormFailure errors -> invalidArgs errors
FormSuccess result -> return result
showD :: SimpleEventLocal -> String
showD = QF.showDate . seStart
showT :: QF.TimeFmt -> SimpleEventLocal -> String
showT fmt = QF.showTime fmt . seStart
slotVal :: SimpleEventLocal -> Text
slotVal = tshow . seStart
getAvailR :: Handler Html
getAvailR = do
QF.QueryForm {..} <- formSuccess =<< runFormGet QF.queryForm
App {appSettings = AppSettings {..}, ..} <- getYesod
let tz = tzByLabel queryTzLabel
offset = fromMaybe queryApptLength $ headMay appApptLengthsMinutes
avail <-
groupByDay .
SL.map (applyTz tz) .
partitionSlots offset queryApptLength .
SL.filter (summaryMatches (locSearch queryLocation)) <$>
FC.readCache appCalendarCache
withUrlRenderer
[hamlet|
$if null avail
No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
$else
$forall eachDay <- avail
$maybe firstSlot <- headMay eachDay
<h4>#{showD firstSlot}
<form .slot-choices>
<input type=hidden name=fooo value=12345>
$forall eachSlot <- eachDay
<button type=submit name=slot value=#{slotVal eachSlot}
.btn.btn-default.btn-small>
#{showT queryTimeFmt eachSlot}
|]
postHomeR :: Handler Html
postHomeR = do
q@QF.QueryForm {..} <- formSuccess =<< runFormPost QF.queryForm
slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
(widget, enctype) <- generateFormPost BF.bookingMForm
defaultLayout $ do
setTitle "Book an appointment"
$(widgetFile "confirm")
postConfirmR :: Handler Html
postConfirmR = do
b@BF.Booking {..} <- formSuccess =<< runFormPost BF.bookingMForm
q@QF.QueryForm {..} <- formSuccess =<< runFormPostNoToken QF.queryForm
slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
App {..} <- getYesod
let utcStart = tzByLabel queryTzLabel `localTimeToUTCTZ` QF.slotLocal slot
utcEnd = fromMinutes queryApptLength `addUTCTime` utcStart
ok e =
summaryMatches (locSearch queryLocation) e &&
withinEvent utcStart utcEnd e
SL.uncons . SL.filter ok <$> FC.readCache appCalendarCache >>= \case
Nothing -> invalidArgs ["No longer available?"] -- TODO should be friendlier
Just (e, _) -> do
addEvent
appCalendarCxt
(appBusyCalendarId appSettings)
SimpleEvent
{ seSummary = bookName
, seStart = utcStart
, seEnd = utcEnd
, seDescr =
"Subject: " <> bookSubject <>
maybe "" ("\nContact: " <>) bookContact
, seLocation = locDescr queryLocation
, seAttendees = [Attendee bookName bookEmail]
}
FC.invalidateCache appCalendarCache
defaultLayout $ do
setTitle "Appointment created"
$(widgetFile "final")
getFinalR :: Handler Html
getFinalR = do
defaultLayout $ do
setTitle "Appointment details"
[whamlet|OKOK|]
-}
src/QueryForm.hs
View file @
bdb06417
...
...
@@ -209,16 +209,22 @@ locationChoiceField = Field {..}
locs
<-
appLocations
.
appSettings
<$>
getYesod
$
(
widgetFile
"query-locations"
)
zonesByContinent
::
Map
Text
[(
Text
,
Text
)]
zonesByContinent
=
Map
.
fromList
$
map
continent
$
groupAllOn
fst
$
map
splitTz
allZones
where
allZones
::
[
TZLabelW
]
allZones
=
[
minBound
..
maxBound
]
sp
litTz
::
TZLabelW
->
(
Text
,
Text
)
sp
litTz
=
(
id
***
drop
1
)
.
break
(
==
'/'
)
.
toPathPiece
sp
ace
'_'
=
' '
sp
ace
c
=
c
continent
::
[(
Text
,
Text
)]
->
(
Text
,[
Text
])
splitTz
::
TZLabelW
->
(
Text
,
(
Text
,
Text
))
splitTz
tz
=
(
cont
,
(
txt
,
omap
space
(
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
)
...
...
@@ -240,9 +246,9 @@ tzSelectorField = Field {..}
<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
x
s <- lookup c zonesByContinent
$forall
x
<-
x
s
<option value=#{
x} :isSuffixOf x
currentTz:selected>#{
x
}
$maybe
z
s <- lookup c zonesByContinent
$forall
(z,txt)
<-
z
s
<option value=#{
toPathPiece z} :z ==
currentTz:selected>#{
txt
}
|]
qControl
::
Text
...
...
src/TamperResistant.hs
deleted
100644 → 0
View file @
31d061c1
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module: TamperResistant
Description: TODO
TODO
-}
module
TamperResistant
(
TamperResistant
(
..
)
)
where
import
ClassyPrelude.Yesod
import
qualified
Data.Binary
as
Bin
import
qualified
Data.ByteString.Base64
as
B64
-- | A wrapper that adds some characters to the PathPiece
-- representation to detect casual tampering. This isn't safe against a
-- determined opponent, so make sure there's another validity check
-- too.
newtype
TamperResistant
a
=
TamperResistant
{
untamper
::
a
}
deriving
(
Show
)
-- | Produce an ASCII string representing a simple checksum.
checksum
::
Hashable
a
=>
a
->
Text
checksum
=
decodeUtf8
.
B64
.
encode
.
toStrict
.
Bin
.
encode
.
hash
-- | This cannot be a character that is used in Base64.
separator
::
Char
separator
=
'*'
instance
PathPiece
a
=>
PathPiece
(
TamperResistant
a
)
where
toPathPiece
(
TamperResistant
a
)
=
checksum
p
<>
singleton
separator
<>
p
where
p
=
toPathPiece
a
fromPathPiece
=
verify
.
(
id
***
drop
1
)
.
break
(
==
separator
)
where
verify
(
s
,
p
)
|
s
==
checksum
p
=
TamperResistant
<$>
fromPathPiece
p
|
otherwise
=
Nothing
templates/query-form.julius
View file @
bdb06417
...
...
@@ -5,10 +5,10 @@ $(function(){
function juggleTimeZone() {
if($(this).hasClass("tzsel") || $(this).attr("name") == "tz-con") {
var continent = $("select[name=tz-con]").val();
var city
Sel
= "select[name=tz-"+continent+"]";
var city
Elt
=
$(
"select[name=tz-"+continent+"]"
)
;
$(".tzsel").hide();
$(
city
Sel)
.show();
$("input[name=tz]").val(c
ontinent + "/" + $(citySel)
.val());
city
Elt
.show();
$("input[name=tz]").val(c
ityElt
.val());
}
sendQuery();
}
...
...
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