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
ec40b552
Commit
ec40b552
authored
May 31, 2018
by
Christopher League
🖥
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Fresh cache for calendar data
parent
496f8c44
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
107 additions
and
46 deletions
+107
-46
src/Application.hs
src/Application.hs
+13
-13
src/Calendar.hs
src/Calendar.hs
+2
-0
src/Foundation.hs
src/Foundation.hs
+2
-0
src/FreshCache.hs
src/FreshCache.hs
+62
-0
src/Handler/Home.hs
src/Handler/Home.hs
+14
-4
src/Settings.hs
src/Settings.hs
+6
-1
stack.yaml
stack.yaml
+8
-28
No files found.
src/Application.hs
View file @
ec40b552
...
...
@@ -21,7 +21,8 @@ module Application
)
where
import
qualified
Calendar
as
Cal
import
Control.Monad.Logger
(
liftLoc
)
import
Control.Monad.Logger
(
logInfoN
,
liftLoc
)
import
qualified
FreshCache
as
FC
import
Import
import
Language.Haskell.TH.Syntax
(
qLocation
)
import
Network.HTTP.Client.TLS
(
getGlobalManager
)
...
...
@@ -58,26 +59,25 @@ mkYesodDispatch "App" resourcesApp
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation
::
AppSettings
->
IO
App
makeFoundation
appSettings
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
=
do
makeFoundation
appSettings
@
AppSettings
{
..
}
=
do
verifySettings
appSettings
appHttpManager
<-
getGlobalManager
appLogger
<-
newStdoutLoggerSet
defaultBufSize
>>=
makeYesodLogger
appStatic
<-
(
if
appMutableStatic
appSettings
then
staticDevel
else
static
)
(
appStaticDir
appSettings
)
(
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
where
partialApp
=
App
{
..
}
appCalendarCxt
=
error
"LOOP: Accessing appCalendarCxt from logFunc"
appCalendarCxt
<-
Cal
.
initialize
logFunc
appHttpManager
(
appCredentials
appSettings
)
appCalendarCxt
<-
Cal
.
initialize
logFunc
appHttpManager
appCredentials
appCalendarCache
<-
unsafeHandler
partialApp
$
FC
.
newCache
$
do
logInfoN
"Refreshing calendar cache"
Cal
.
listAvailMinusBusy
appCalendarCxt
appFreeCalendarId
appBusyCalendarId
appLookahead
return
App
{
..
}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
...
...
src/Calendar.hs
View file @
ec40b552
...
...
@@ -19,6 +19,8 @@ module Calendar
,
Context
,
CalendarId
,
SimpleEvent
(
..
)
,
SimpleEventUTC
,
SimpleEventLocal
,
initialize
,
applyTz
,
groupByDay
...
...
src/Foundation.hs
View file @
ec40b552
...
...
@@ -14,6 +14,7 @@
module
Foundation
where
import
qualified
Calendar
as
Cal
import
qualified
FreshCache
as
FC
import
qualified
Control.Monad.Catch
as
MC
import
Control.Monad.Logger
(
LogSource
)
import
qualified
Data.CaseInsensitive
as
CI
...
...
@@ -35,6 +36,7 @@ data App = App
,
appHttpManager
::
Manager
,
appLogger
::
Logger
,
appCalendarCxt
::
Cal
.
Context
,
appCalendarCache
::
FC
.
Cache
(
HandlerFor
App
)
[
Cal
.
SimpleEventUTC
]
}
data
MenuItem
=
MenuItem
...
...
src/FreshCache.hs
0 → 100644
View file @
ec40b552
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module: FreshCache
Description: TODO
TODO
-}
module
FreshCache
(
Cache
,
newCache
,
readCache
,
cacheDemo
)
where
import
ClassyPrelude.Yesod
import
Control.Concurrent
(
threadDelay
)
import
Data.Time.Clock
(
NominalDiffTime
,
diffUTCTime
)
newtype
Cache
m
a
=
Cache
(
MVar
(
a
,
UTCTime
,
m
a
))
newCache
::
MonadIO
m
=>
m
a
->
m
(
Cache
m
a
)
newCache
refresh
=
do
now
<-
liftIO
getCurrentTime
result
<-
refresh
Cache
<$>
newMVar
(
result
,
now
,
refresh
)
readCache
::
MonadUnliftIO
m
=>
Cache
m
a
->
NominalDiffTime
->
m
a
readCache
(
Cache
mvar
)
maxAge
=
modifyMVar
mvar
$
\
val
@
(
result
,
prev
,
refresh
)
->
do
now
<-
liftIO
getCurrentTime
if
now
`
diffUTCTime
`
prev
<
maxAge
then
return
(
val
,
result
)
else
do
newResult
<-
refresh
return
((
newResult
,
now
,
refresh
),
newResult
)
cacheDemo
::
IO
()
cacheDemo
=
do
let
w
sec
=
threadDelay
(
sec
*
1000
*
1000
)
pr
::
Int
->
Text
->
IO
()
pr
i
r
=
say
(
tshow
i
<>
": "
<>
r
)
k
<-
newCache
$
do
say
"Refreshing..."
w
2
say
"Refreshing...done"
return
$
asText
"OK"
threads
<-
forM
[
1
..
5
]
$
\
i
->
async
$
do
readCache
k
6
>>=
pr
i
w
(
i
+
1
)
readCache
k
6
>>=
pr
i
w
(
i
+
2
)
readCache
k
6
>>=
pr
i
mapM_
waitAsync
threads
say
"Now forcing an immediate refresh"
readCache
k
0
>>=
pr
0
src/Handler/Home.hs
View file @
ec40b552
...
...
@@ -11,6 +11,7 @@ module Handler.Home where
import
qualified
Calendar
as
Cal
import
qualified
Data.Time.Format
as
TF
import
qualified
FreshCache
as
FC
import
Import
import
Text.Julius
(
RawJS
(
..
))
...
...
@@ -130,8 +131,15 @@ queryForm extra = do
|]
return
(
q
,
widget
)
readCache
::
Handler
[
Cal
.
SimpleEventUTC
]
readCache
=
(
appCalendarCache
&&&
appCacheExpiry
.
appSettings
)
<$>
getYesod
>>=
uncurry
FC
.
readCache
getHomeR
::
Handler
Html
getHomeR
=
do
-- Start (but don't wait for) refresh of calendar
void
$
async
$
readCache
(
widget
,
enctype
)
<-
generateFormPost
queryForm
(
idSpinner
,
idAvail
,
idAlert
)
<-
(,,)
<$>
newIdent
<*>
newIdent
<*>
newIdent
defaultLayout
...
...
@@ -144,10 +152,10 @@ getAvailR = do
FormMissing
->
invalidArgs
[
"missing"
]
FormFailure
errs
->
invalidArgs
errs
FormSuccess
q
->
do
App
{
..
}
<-
getYesod
let
AppSettings
{
..
}
=
appSettings
tz
=
tzByLabel
$
queryTzLabel
q
evs1
<-
Cal
.
listAvailMinusBusy
appCalendarCxt
appFreeCalendarId
appBusyCalendarId
appLookahead
App
Settings
{
..
}
<-
appSettings
<$>
getYesod
let
tz
=
tzByLabel
$
queryTzLabel
q
let
weeks
=
floor
(
appLookahead
/
secondsPerWeek
)
::
Int
evs1
<-
readCache
let
evs2
=
Cal
.
partitionSlots
(
apptLengthMinutes
(
queryApptLength
q
))
evs1
let
evs'
=
Cal
.
groupByDay
$
map
(
Cal
.
applyTz
tz
)
evs2
fmt
=
if
queryTimeFmt
q
==
Time12h
...
...
@@ -159,6 +167,8 @@ getAvailR = do
": "
<>
unpack
(
Cal
.
seSummary
e
)
withUrlRenderer
[
hamlet
|
$if null evs'
No appointments available in the next #{weeks} weeks.
$forall day <- evs'
$maybe firstSlot <- headMay day
<h4>#{showDate firstSlot}
...
...
src/Settings.hs
View file @
ec40b552
...
...
@@ -34,6 +34,9 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload
,
widgetFileReload
)
secondsPerWeek
::
NominalDiffTime
secondsPerWeek
=
7
*
24
*
60
*
60
-- | Represent the valid appointment lengths, in minutes.
newtype
ApptLength
=
ApptLengthMinutes
{
apptLengthMinutes
::
Int
}
...
...
@@ -95,6 +98,7 @@ data AppSettings = AppSettings
,
appLookahead
::
NominalDiffTime
,
appApptLengths
::
[
ApptLength
]
,
appDefaultApptLength
::
ApptLength
,
appCacheExpiry
::
NominalDiffTime
}
newtype
TZLabelW
=
...
...
@@ -143,10 +147,11 @@ instance FromJSON AppSettings where
appLocations
<-
makeLocs
<$>
o
.:
"locations"
appFreeCalendarId
<-
o
.:
"free-calendar"
appBusyCalendarId
<-
o
.:
"busy-calendar"
appLookahead
<-
(
7
*
24
*
60
*
60
*
)
<$>
o
.:
"look-ahead-weeks"
appLookahead
<-
(
*
secondsPerWeek
)
<$>
o
.:
"look-ahead-weeks"
appApptLengths
<-
o
.:
"appointment-lengths-minutes"
appDefaultApptLength
<-
o
.:
"default-appointment-length"
appCredentials
<-
o
.:
"calendar-credentials"
appCacheExpiry
<-
o
.:?
"calendar-refresh-seconds"
.!=
(
if
dev
then
15
else
300
)
return
AppSettings
{
..
}
...
...
stack.yaml
View file @
ec40b552
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
...
...
@@ -8,37 +6,13 @@
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver
:
lts-11.10
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages
:
-
.
-
.
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps
:
-
git
:
git@github.com:brendanhay/gogol.git
commit
:
344c9f781560e1ed8395b17e370ba1b085f2edc2
...
...
@@ -47,10 +21,16 @@ extra-deps:
-
gogol
-
gogol-apps-calendar
# Nix support
nix
:
enable
:
true
pure
:
false
# Build options
build
:
haddock
:
true
haddock-internal
:
true
# Override default flag values for local packages and extra-deps
# flags: {}
...
...
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