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
be1dc5dc
Commit
be1dc5dc
authored
May 31, 2018
by
Christopher League
🖥
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Some more docs and dependency cleanup, hfmt
parent
ed0bb11e
Changes
17
Hide whitespace changes
Inline
Side-by-side
Showing
17 changed files
with
261 additions
and
223 deletions
+261
-223
app/DevelMain.hs
app/DevelMain.hs
+37
-34
app/auth.hs
app/auth.hs
+2
-2
app/main.hs
app/main.hs
+2
-2
src/Application.hs
src/Application.hs
+40
-38
src/Calendar.hs
src/Calendar.hs
+15
-15
src/Foundation.hs
src/Foundation.hs
+5
-6
src/FreshCache.hs
src/FreshCache.hs
+12
-2
src/Handler/Common.hs
src/Handler/Common.hs
+13
-12
src/Handler/Home.hs
src/Handler/Home.hs
+59
-47
src/Import.hs
src/Import.hs
+4
-4
src/Import/NoFoundation.hs
src/Import/NoFoundation.hs
+10
-7
src/Settings.hs
src/Settings.hs
+4
-4
src/Settings/Auth.hs
src/Settings/Auth.hs
+4
-3
src/Settings/StaticFiles.hs
src/Settings/StaticFiles.hs
+3
-2
test/Handler/CommonSpec.hs
test/Handler/CommonSpec.hs
+15
-12
test/Handler/HomeSpec.hs
test/Handler/HomeSpec.hs
+18
-17
test/TestImport.hs
test/TestImport.hs
+18
-16
No files found.
app/DevelMain.hs
View file @
be1dc5dc
...
...
@@ -27,73 +27,76 @@
--
-- There is more information about this approach,
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module
DevelMain
where
import
Prelude
import
Application
(
getApplicationRepl
,
shutdownApp
)
import
Application
(
getApplicationRepl
,
shutdownApp
)
import
Prelude
import
Control.Exception
(
finally
)
import
Control.Monad
((
>=>
)
)
import
Control.Concurrent
import
Data.IORef
import
Foreign.Store
import
Network.Wai.Handler.Warp
import
GHC.Word
import
Control.Concurrent
import
Control.Exception
(
finally
)
import
Control.Monad
((
>=>
))
import
Data.IORef
import
Foreign.Store
import
GHC.Word
import
Network.Wai.Handler.Warp
-- | Start or restart the server.
-- newStore is from foreign-store.
-- A Store holds onto some data across ghci reloads
update
::
IO
()
update
=
do
mtidStore
<-
lookupStore
tidStoreNum
case
mtidStore
of
mtidStore
<-
lookupStore
tidStoreNum
case
mtidStore
-- no server running
Nothing
->
do
done
<-
storeAction
doneStore
newEmptyMVar
tid
<-
start
done
_
<-
storeAction
(
Store
tidStoreNum
)
(
newIORef
tid
)
return
()
of
Nothing
->
do
done
<-
storeAction
doneStore
newEmptyMVar
tid
<-
start
done
_
<-
storeAction
(
Store
tidStoreNum
)
(
newIORef
tid
)
return
()
-- server is already running
Just
tidStore
->
restartAppInNewThread
tidStore
Just
tidStore
->
restartAppInNewThread
tidStore
where
doneStore
::
Store
(
MVar
()
)
doneStore
=
Store
0
-- shut the server down with killThread and wait for the done signal
restartAppInNewThread
::
Store
(
IORef
ThreadId
)
->
IO
()
restartAppInNewThread
tidStore
=
modifyStoredIORef
tidStore
$
\
tid
->
do
restartAppInNewThread
tidStore
=
modifyStoredIORef
tidStore
$
\
tid
->
do
killThread
tid
withStore
doneStore
takeMVar
readStore
doneStore
>>=
start
-- | Start the server in a separate thread.
start
::
MVar
()
-- ^ Written to when the thread is killed.
->
IO
ThreadId
start
::
MVar
()
-- ^ Written to when the thread is killed.
->
IO
ThreadId
start
done
=
do
(
port
,
site
,
app
)
<-
getApplicationRepl
forkIO
(
finally
(
runSettings
(
setPort
port
defaultSettings
)
app
)
(
port
,
site
,
app
)
<-
getApplicationRepl
forkIO
(
finally
(
runSettings
(
setPort
port
defaultSettings
)
app
)
-- Note that this implies concurrency
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
(
putMVar
done
()
>>
shutdownApp
site
))
(
putMVar
done
()
>>
shutdownApp
site
))
-- | kill the server
shutdown
::
IO
()
shutdown
=
do
mtidStore
<-
lookupStore
tidStoreNum
case
mtidStore
of
mtidStore
<-
lookupStore
tidStoreNum
case
mtidStore
-- no server running
Nothing
->
putStrLn
"no Yesod app running"
Just
tidStore
->
do
withStore
tidStore
$
readIORef
>=>
killThread
putStrLn
"Yesod app is shutdown"
of
Nothing
->
putStrLn
"no Yesod app running"
Just
tidStore
->
do
withStore
tidStore
$
readIORef
>=>
killThread
putStrLn
"Yesod app is shutdown"
tidStoreNum
::
Word32
tidStoreNum
=
1
modifyStoredIORef
::
Store
(
IORef
a
)
->
(
a
->
IO
a
)
->
IO
()
modifyStoredIORef
store
f
=
withStore
store
$
\
ref
->
do
modifyStoredIORef
store
f
=
withStore
store
$
\
ref
->
do
v
<-
readIORef
ref
f
v
>>=
writeIORef
ref
app/auth.hs
View file @
be1dc5dc
import
Prelude
(
IO
)
import
Settings.Auth
(
authorizeMain
)
import
Prelude
(
IO
)
import
Settings.Auth
(
authorizeMain
)
main
::
IO
()
main
=
authorizeMain
app/main.hs
View file @
be1dc5dc
import
Prelude
(
IO
)
import
Application
(
appMain
)
import
Application
(
appMain
)
import
Prelude
(
IO
)
main
::
IO
()
main
=
appMain
src/Application.hs
View file @
be1dc5dc
...
...
@@ -4,7 +4,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module
Application
...
...
@@ -20,30 +19,29 @@ module Application
,
handler
)
where
import
qualified
Calendar
as
Cal
import
Control.Monad.Logger
(
logInfoN
,
liftLoc
)
import
qualified
FreshCache
as
FC
import
qualified
Calendar
as
Cal
import
Control.Monad.Logger
(
liftLoc
,
logInfoN
)
import
Data.Time.Clock
(
NominalDiffTime
)
import
qualified
FreshCache
as
FC
import
Import
import
Language.Haskell.TH.Syntax
(
qLocation
)
import
Data.Time.Clock
(
NominalDiffTime
)
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
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 all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
...
...
@@ -63,24 +61,28 @@ fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation
::
AppSettings
->
IO
App
makeFoundation
appSettings
@
AppSettings
{
..
}
=
do
makeFoundation
appSettings
@
AppSettings
{
..
}
=
do
appHttpManager
<-
getGlobalManager
appLogger
<-
newStdoutLoggerSet
defaultBufSize
>>=
makeYesodLogger
appStatic
<-
(
if
appMutableStatic
then
staticDevel
else
static
)
appStaticDir
let
partialApp
=
App
{
..
}
where
appCalendarCxt
=
error
"partialApp loop: Accessing appCalendarCxt"
appGetCalendar
=
error
"partialApp loop: Accessing appGetCalendar"
logFunc
loc
src
lv
=
whenM
(
shouldLogIO
partialApp
""
lv
)
.
messageLoggerSource
partialApp
appLogger
loc
src
lv
(
if
appMutableStatic
then
staticDevel
else
static
)
appStaticDir
let
partialApp
=
App
{
..
}
where
appCalendarCxt
=
error
"partialApp loop: Accessing appCalendarCxt"
appGetCalendar
=
error
"partialApp loop: Accessing appGetCalendar"
logFunc
loc
src
lv
=
whenM
(
shouldLogIO
partialApp
""
lv
)
.
messageLoggerSource
partialApp
appLogger
loc
src
lv
appCalendarCxt
<-
Cal
.
initialize
logFunc
appHttpManager
appCredentials
cache
<-
unsafeHandler
partialApp
$
FC
.
newCache
$
do
logInfoN
"Refreshing calendar cache"
Cal
.
listAvailMinusBusy
appCalendarCxt
appFreeCalendarId
appBusyCalendarId
$
fromWeeks
appLookaheadWeeks
cache
<-
unsafeHandler
partialApp
$
FC
.
newCache
$
do
logInfoN
"Refreshing calendar cache"
Cal
.
listAvailMinusBusy
appCalendarCxt
appFreeCalendarId
appBusyCalendarId
$
fromWeeks
appLookaheadWeeks
let
appGetCalendar
=
FC
.
readCache
cache
.
fromMaybe
appCacheExpiry
return
App
{
..
}
...
...
src/Calendar.hs
View file @
be1dc5dc
...
...
@@ -14,9 +14,9 @@ calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging.
-}
module
Calendar
(
Scope
,
Credentials
,
Context
(
Calendar
Scope
,
C
alendarC
redentials
,
C
alendarC
ontext
,
CalendarId
,
SimpleEvent
(
..
)
,
SimpleEventUTC
...
...
@@ -47,25 +47,25 @@ import qualified Network.Google.Auth.ApplicationDefault as Google
import
System.Log.FastLogger
(
toLogStr
)
-- | Google authorization scope representing calendar operations.
type
Scope
=
'
[
"https://www.googleapis.com/auth/calendar"
]
type
Calendar
Scope
=
'
[
"https://www.googleapis.com/auth/calendar"
]
-- | Credentials needed for accessing the calendar.
data
Credentials
data
C
alendarC
redentials
=
MockCreds
|
GoogleCreds
(
Google
.
Credentials
Scope
)
|
GoogleCreds
(
Google
.
Credentials
Calendar
Scope
)
-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
instance
Show
Credentials
where
instance
Show
C
alendarC
redentials
where
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
Credentials
where
instance
FromJSON
C
alendarC
redentials
where
parseJSON
=
Js
.
withObject
"Credentials"
$
\
o
->
Js
.
withObject
"C
alendarC
redentials"
$
\
o
->
o
.:
"client_id"
>>=
\
c
->
if
c
==
asText
"mock"
then
return
MockCreds
...
...
@@ -74,9 +74,9 @@ instance FromJSON Credentials where
-- | This represents a ready-to-use environment for calendar
-- operations.
data
Context
data
C
alendarC
ontext
=
MockCxt
Day
|
GoogleCxt
(
Google
.
Env
Scope
)
|
GoogleCxt
(
Google
.
Env
Calendar
Scope
)
-- | Use the static credentials to create a dynamic context for
-- calendar operations. The Google environment requires a logging
...
...
@@ -85,8 +85,8 @@ data Context
initialize
::
(
Loc
->
LogSource
->
LogLevel
->
LogStr
->
IO
()
)
->
Manager
->
Credentials
->
IO
Context
->
C
alendarC
redentials
->
IO
C
alendarC
ontext
initialize
appLog
_
MockCreds
=
do
appLog
defaultLoc
""
LevelWarn
"Using mock calendar"
MockCxt
.
succ
.
utctDay
<$>
getCurrentTime
...
...
@@ -156,7 +156,7 @@ sampleEvent d (summary, f, hmm1, hmm2) =
-- | Fetch events from a single calendar.
listUpcoming
::
MonadResource
m
=>
Context
=>
C
alendarC
ontext
->
CalendarId
->
NominalDiffTime
-- ^How far to look ahead
->
m
[
SimpleEventUTC
]
...
...
@@ -244,7 +244,7 @@ availMinusBusy (a:aa) (b:bb)
-- between them.
listAvailMinusBusy
::
(
MonadResource
m
,
MonadUnliftIO
m
)
=>
Context
=>
C
alendarC
ontext
->
CalendarId
-- ^Calendar with available times
->
CalendarId
-- ^Calendar with busy times
->
NominalDiffTime
-- ^How far to look ahead
...
...
src/Foundation.hs
View file @
be1dc5dc
...
...
@@ -19,7 +19,6 @@ module Foundation
,
unsafeHandler
)
where
import
qualified
Calendar
as
Cal
import
qualified
Control.Monad.Catch
as
MC
import
Control.Monad.Logger
(
LogSource
)
import
qualified
Data.CaseInsensitive
as
CI
...
...
@@ -37,12 +36,12 @@ import Yesod.Default.Util (addStaticContentExternal)
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data
App
=
App
{
appSettings
::
AppSettings
,
appStatic
::
Static
-- ^ Settings for static file serving.
{
appSettings
::
AppSettings
,
appStatic
::
Static
-- ^ Settings for static file serving.
,
appHttpManager
::
Manager
,
appLogger
::
Logger
,
appCalendarCxt
::
Cal
.
Context
,
appGetCalendar
::
Maybe
NominalDiffTime
->
HandlerFor
App
[
Cal
.
SimpleEventUTC
]
,
appLogger
::
Logger
,
appCalendarCxt
::
Cal
endar
Context
,
appGetCalendar
::
Maybe
NominalDiffTime
->
HandlerFor
App
[
SimpleEventUTC
]
-- ^ Fetch latest available times from the calendars. Return cached
-- version if it's less than given age, which defaults to
-- 'appCacheExpiry'.
...
...
src/FreshCache.hs
View file @
be1dc5dc
...
...
@@ -4,9 +4,12 @@
{-|
Module: FreshCache
Description:
TODO
Description:
Cache the result of an expensive action
TODO
This utility caches the result of an expensive action for a specified
amount of time. If the result is requested again within that time, the
existing one is used. If it is requested after the time is expired, we
automatically refresh it. Should be thread-safe.
-}
module
FreshCache
(
Cache
...
...
@@ -19,15 +22,21 @@ import ClassyPrelude.Yesod
import
Control.Concurrent
(
threadDelay
)
import
Data.Time.Clock
(
NominalDiffTime
,
diffUTCTime
)
-- | The cache structure. Saves the value 'a' which can be refreshed or
-- accessed within the monad 'm'.
newtype
Cache
m
a
=
Cache
(
MVar
(
a
,
UTCTime
,
m
a
))
-- | Create a new cache by running the action and saving it with a
-- timestamp.
newCache
::
MonadIO
m
=>
m
a
->
m
(
Cache
m
a
)
newCache
refresh
=
do
now
<-
liftIO
getCurrentTime
result
<-
refresh
Cache
<$>
newMVar
(
result
,
now
,
refresh
)
-- | Retrieve the value from the cache if it's within the specified
-- maximum age. Otherwise, refresh it and return the new value.
readCache
::
MonadUnliftIO
m
=>
Cache
m
a
->
NominalDiffTime
->
m
a
readCache
(
Cache
mvar
)
maxAge
=
modifyMVar
mvar
$
\
val
@
(
result
,
prev
,
refresh
)
->
do
...
...
@@ -38,6 +47,7 @@ readCache (Cache mvar) maxAge =
newResult
<-
refresh
return
((
newResult
,
now
,
refresh
),
newResult
)
-- | A little concurrent test program using the cache.
cacheDemo
::
IO
()
cacheDemo
=
do
let
w
sec
=
threadDelay
(
sec
*
1000
*
1000
)
...
...
src/Handler/Common.hs
View file @
be1dc5dc
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions.
module
Handler.Common
where
import
Data.FileEmbed
(
embedFile
)
import
Import
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"
)
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"
)
getRobotsR
=
return
$
TypedContent
typePlain
$
toContent
$
(
embedFile
"config/robots.txt"
)
src/Handler/Home.hs
View file @
be1dc5dc
...
...
@@ -9,37 +9,40 @@
module
Handler.Home
where
import
qualified
Calendar
as
Cal
import
qualified
Calendar
as
Cal
import
qualified
Data.Time.Format
as
TF
import
Import
import
Text.Julius
(
RawJS
(
..
))
import
Text.Julius
(
RawJS
(
..
))
apptLengthOptions
::
Handler
(
OptionList
Int
)
apptLengthOptions
=
do
lengths
<-
appApptLengthsMinutes
.
appSettings
<$>
getYesod
let
toOption
m
=
Option
{
optionDisplay
=
tshow
m
<>
" minute"
,
optionInternalValue
=
m
,
optionExternalValue
=
tshow
m
let
toOption
m
=
Option
{
optionDisplay
=
tshow
m
<>
" minute"
,
optionInternalValue
=
m
,
optionExternalValue
=
tshow
m
}
okLength
m
=
if
m
`
elem
`
lengths
then
Just
m
else
Nothing
return
$
OptionList
{
olOptions
=
map
toOption
lengths
,
olReadExternal
=
fromPathPiece
>=>
okLength
}
okLength
m
=
if
m
`
elem
`
lengths
then
Just
m
else
Nothing
return
$
OptionList
{
olOptions
=
map
toOption
lengths
,
olReadExternal
=
fromPathPiece
>=>
okLength
}
locationField
::
Field
Handler
Location
locationField
=
Field
{
..
}
locationField
=
Field
{
..
}
where
fieldParse
[]
_
=
return
$
Left
$
SomeMessage
$
MsgInputNotFound
"location"
fieldParse
(
txt
:
_
)
_
=
do
locs
<-
appLocations
.
appSettings
<$>
getYesod
return
$
case
find
((
==
txt
)
.
locId
)
locs
of
Nothing
->
Left
$
SomeMessage
$
MsgInvalidEntry
txt
Just
loc
->
Right
$
Just
loc
return
$
case
find
((
==
txt
)
.
locId
)
locs
of
Nothing
->
Left
$
SomeMessage
$
MsgInvalidEntry
txt
Just
loc
->
Right
$
Just
loc
fieldView
i
_
attrs
val
_
=
do
locs
<-
appLocations
.
appSettings
<$>
getYesod
[
whamlet
|
...
...
@@ -54,8 +57,9 @@ locationField = Field{..}
|]
fieldEnctype
=
UrlEncoded
data
TimeFmt
=
Time12h
|
Time24h
data
TimeFmt
=
Time12h
|
Time24h
deriving
(
Eq
,
Show
,
Enum
,
Bounded
)
instance
PathPiece
TimeFmt
where
...
...
@@ -63,19 +67,21 @@ instance PathPiece TimeFmt where
toPathPiece
Time24h
=
"24h"
fromPathPiece
"12h"
=
Just
Time12h
fromPathPiece
"24h"
=
Just
Time24h
fromPathPiece
_
=
Nothing
fromPathPiece
_
=
Nothing
instance
Default
TimeFmt
where
def
=
Time12h
timeFmtOptions
::
Handler
(
OptionList
TimeFmt
)
timeFmtOptions
=
return
$
OptionList
{
olReadExternal
=
fromPathPiece
,
olOptions
=
[
Option
"12-hour (AM/PM)"
Time12h
(
toPathPiece
Time12h
)
,
Option
"24-hour"
Time24h
(
toPathPiece
Time24h
)
]
}
timeFmtOptions
=
return
$
OptionList
{
olReadExternal
=
fromPathPiece
,
olOptions
=
[
Option
"12-hour (AM/PM)"
Time12h
(
toPathPiece
Time12h
)
,
Option
"24-hour"
Time24h
(
toPathPiece
Time24h
)
]
}
data
QueryForm
=
QueryForm
{
queryApptLength
::
Int
...
...
@@ -83,22 +89,27 @@ data QueryForm = QueryForm
,
queryTzLabel
::
TZLabelW
,
queryLocation
::
Location
,
querySlot
::
Maybe
Text
-- TBD
}
deriving
Show
}
deriving
(
Show
)
queryForm
::
Html
->
MForm
Handler
(
FormResult
QueryForm
,
Widget
)
queryForm
extra
=
do
AppSettings
{
..
}
<-
appSettings
<$>
getYesod
AppSettings
{
..
}
<-
appSettings
<$>
getYesod
qc
<-
newIdent
let
qs
n
=
""
{
fsName
=
Just
n
,
fsId
=
Just
n
,
fsAttrs
=
[(
"class"
,
qc
)]}
(
lenRes
,
lenView
)
<-
mreq
(
selectField
apptLengthOptions
)
(
qs
"len"
)
(
headMay
appApptLengthsMinutes
)
(
lenRes
,
lenView
)
<-
mreq
(
selectField
apptLengthOptions
)
(
qs
"len"
)
(
headMay
appApptLengthsMinutes
)
(
fmtRes
,
fmtView
)
<-
mreq
(
selectField
timeFmtOptions
)
(
qs
"fmt"
)
(
Just
def
)
(
locRes
,
locView
)
<-
mreq
locationField
(
qs
"loc"
)
(
headMay
appLocations
)
(
slotRes
,
_
)
<-
mopt
textField
(
qs
"slot"
)
Nothing
let
q
=
QueryForm
<$>
lenRes
<*>
fmtRes
<*>
pure
appDefaultTimeZone
<*>
locRes
<*>
slotRes
widget
=
do
toWidget
[
julius
|
let
q
=
QueryForm
<$>
lenRes
<*>
fmtRes
<*>
pure
appDefaultTimeZone
<*>
locRes
<*>
slotRes
widget
=
do
toWidget
[
julius
|
$(function(){
$(".#{rawJS qc}").change(sendQuery);
sendQuery();
...
...
@@ -113,7 +124,7 @@ queryForm extra = do
});
}
|]
[
whamlet
|
[
whamlet
|
#{extra}
<p>
Show
...
...
@@ -130,14 +141,14 @@ queryForm extra = do
return
(
q
,
widget
)
getHomeR
::
Handler
Html
getHomeR
=
do
getHomeR
-- Start (but don't wait for) refresh of calendar
App
{
..
}
<-
getYesod
=
do
App
{
..
}
<-
getYesod
void
$
async
$
appGetCalendar
Nothing
(
widget
,
enctype
)
<-
generateFormPost
queryForm
(
idSpinner
,
idAvail
,
idAlert
)
<-
(,,)
<$>
newIdent
<*>
newIdent
<*>
newIdent
defaultLayout
$
(
widgetFile
"step1"
)
defaultLayout
$
(
widgetFile
"step1"
)
getAvailR
::
Handler
Html
getAvailR
=
do
...
...
@@ -146,18 +157,19 @@ getAvailR = do
FormMissing
->
invalidArgs
[
"missing"
]
FormFailure
errs
->
invalidArgs
errs
FormSuccess
q
->
do
App
{
appSettings
=
AppSettings
{
..
},
..
}
<-
getYesod
App
{
appSettings
=
AppSettings
{
..
},
..
}
<-
getYesod
let
tz
=
tzByLabel
$
queryTzLabel
q
evs1
<-
appGetCalendar
Nothing
let
evs2
=
Cal
.
partitionSlots
(
queryApptLength
q
)
evs1
let
evs'
=
Cal
.
groupByDay
$
map
(
Cal
.
applyTz
tz
)
evs2
fmt
=
if
queryTimeFmt
q
==
Time12h
then
"%l:%M %p"
else
"%H:%M"
fmt
=
if
queryTimeFmt
q
==
Time12h
then
"%l:%M %p"
else
"%H:%M"
showDate
=
TF
.
formatTime
TF
.
defaultTimeLocale
"%A %e %B"
.
Cal
.
seStart
showTime
e
=
TF
.
formatTime
TF
.
defaultTimeLocale
fmt
(
Cal
.
seStart
e
)
<>
": "
<>
unpack
(
Cal
.
seSummary
e
)
TF
.
formatTime
TF
.
defaultTimeLocale
fmt
(
Cal
.
seStart
e
)
<>
": "
<>
unpack
(
Cal
.
seSummary
e
)
withUrlRenderer
[
hamlet
|
$if null evs'
...
...
src/Import.hs
View file @
be1dc5dc
module
Import
(
module
Import
)
where
(
module
Import
)
where
import
Foundation
as
Import
import
Import.NoFoundation
as
Import
import
Foundation
as
Import
import
Import.NoFoundation
as
Import
src/Import/NoFoundation.hs
View file @
be1dc5dc
{-# LANGUAGE CPP #-}
module
Import.NoFoundation
(
module
Import
)
where
(
module
Import
)
where
import
ClassyPrelude.Yesod
as
Import
import
Settings
as
Import
import
Settings.StaticFiles
as
Import
import
Yesod.Core.Types
as
Import
(
loggerSet
)
import
Yesod.Default.Config2
as
Import
import
Calendar
as
Import
(
CalendarContext
,
SimpleEventUTC
)
import
ClassyPrelude.Yesod
as
Import
import
Settings
as
Import
import
Settings.StaticFiles
as
Import
import
Yesod.Core.Types
as
Import
(
loggerSet
)
import
Yesod.Default.Config2
as
Import
src/Settings.hs
View file @
be1dc5dc
...
...
@@ -27,7 +27,7 @@ module Settings
,
combineScripts
)
where
import
qualified
Calendar
as
Cal
import
Calendar
(
CalendarCredentials
,
CalendarId
)
import
ClassyPrelude.Yesod