Commit 496f8c44 authored by Christopher League's avatar Christopher League
Browse files

Clean up, document Calendar

parent d65b2142
......@@ -6,9 +6,6 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/ HomeR GET
/confirm ConfirmR POST
/api/available AvailR GET
/cals CalListR GET
/comments CommentR POST
/available AvailR GET
......@@ -23,8 +23,8 @@ calendar-credentials:
client_id: "_env:BOOKME_GOOGLE_ID:mock"
client_secret: "_env:BOOKME_GOOGLE_SECRET:"
refresh_token: "_env:BOOKME_GOOGLE_REFRESH:"
free-calendar: _env:BOOKME_FREE_CAL:uhqg996jdq8gc8r8g1bee8clc8@group.calendar.google.com
busy-calendar: _env:BOOKME_BUSY_CAL:cleague@gmail.com
free-calendar: _env:BOOKME_FREE_CAL:free
busy-calendar: _env:BOOKME_BUSY_CAL:busy
look-ahead-weeks: 4
# By default, `yesod devel` runs in development, and built executables use
......
......@@ -21,17 +21,9 @@ module Application
) where
import qualified Calendar as Cal
import Control.Lens ((.~), (<&>))
import Control.Monad.Logger (liftLoc)
import Control.Monad.Logger (defaultLoc)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Import
import Language.Haskell.TH.Syntax (qLocation)
import qualified Network.Google as Google
import Network.Google.AppsCalendar (calendarScope)
import Network.Google.Auth (OAuthClient (..))
import qualified Network.Google.Auth.ApplicationDefault as Google
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings,
......@@ -47,13 +39,10 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
destination,
mkRequestLogger,
outputFormat)
import System.Environment (getEnv)
import System.Log.FastLogger (defaultBufSize,
newStdoutLoggerSet,
toLogStr)
import Handler.Comment
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
......
......@@ -2,58 +2,92 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module: Calendar
Description: Query and manipulate calendars and events.
This module contains facilities for querying and manipulating
calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging.
-}
module Calendar
( Credentials
, Scope
( Scope
, Credentials
, Context
, CalendarId
, SimpleEvent(..)
, initialize
, listCalendars
, applyTz
, groupByDay
, listAvailMinusBusy
, partitionSlots
) where
import ClassyPrelude.Yesod
import Control.Lens ((.~), (<&>), (^.))
import Control.Monad.Logger (Loc, LogSource, LogStr, defaultLoc)
import Control.Monad.Logger (Loc, LogSource, LogStr,
defaultLoc)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Data.Function ((&))
import Data.Time.Clock (DiffTime,
NominalDiffTime,
addUTCTime)
import Data.Time.LocalTime (LocalTime (..))
import Data.Time.Zones (TZ, utcToLocalTimeTZ)
import qualified Network.Google as Google
import Network.Google.AppsCalendar
import System.Log.FastLogger (toLogStr)
import qualified Data.Aeson as Js
import qualified Network.Google as Google
import qualified Network.Google.Auth as Google
import qualified Network.Google.Auth as Google
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"]
mockClientId :: Text
mockClientId = "mock"
-- | Credentials needed for accessing the calendar.
data Credentials
= MockCreds
| GoogleCreds (Google.Credentials Scope)
-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
instance Show Credentials where
show MockCreds = "<mock>"
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
parseJSON = Js.withObject "Credentials" $ \o ->
o .: "client_id" >>= \c ->
if c == mockClientId
then return MockCreds
else either fail (return . GoogleCreds) $
Google.fromJSONCredentials $ Js.encode o
parseJSON =
Js.withObject "Credentials" $ \o ->
o .: "client_id" >>= \c ->
if c == asText "mock"
then return MockCreds
else either fail (return . GoogleCreds) $
Google.fromJSONCredentials $ Js.encode o
-- | This represents a ready-to-use environment for calendar
-- operations.
data Context
= MockCxt
= MockCxt Day
| GoogleCxt (Google.Env Scope)
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
initialize :: LogFunc -> Manager -> Credentials -> IO Context
-- | Use the static credentials to create a dynamic context for
-- calendar operations. The Google environment requires a logging
-- function and an HTTP manager. If using a mock calendar, a warning is
-- printed using the logging function.
initialize ::
(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Manager
-> Credentials
-> IO Context
initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar"
return MockCxt
MockCxt . succ . utctDay <$> getCurrentTime
initialize appLog manager (GoogleCreds creds) =
GoogleCxt <$>
(Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
......@@ -61,14 +95,176 @@ initialize appLog manager (GoogleCreds creds) =
gooLog level builder =
appLog defaultLoc "" lv (toLogStr (toLazyByteString builder))
where
lv = case level of
Google.Info -> LevelInfo
Google.Error -> LevelError
Google.Debug -> LevelDebug
Google.Trace -> LevelOther "trace"
listCalendars :: MonadResource m => Context -> m [Text]
listCalendars MockCxt = return []
listCalendars (GoogleCxt env) = do
xs <- Google.runGoogle env $ Google.send calendarListList
return $ mapMaybe (^. cleSummary) (xs ^. clItems)
lv =
case level of
Google.Info -> LevelInfo
Google.Error -> LevelError
Google.Debug -> LevelDebug
Google.Trace -> LevelOther "trace"
-- | A record containing just the essential event data, abstracted over
-- the type of the time-stamp.
data SimpleEvent t = SimpleEvent
{ seSummary :: Text
, seStart :: t
, seEnd :: t
} deriving (Show)
type SimpleEventUTC = SimpleEvent UTCTime
type SimpleEventLocal = SimpleEvent LocalTime
-- | Extract essential event data from a Google @Event@ object.
simplifyEvent :: Event -> Maybe SimpleEventUTC
simplifyEvent e = do
let seSummary = fromMaybe "" $ e ^. eSummary
seStart <- e ^. eStart >>= (^. edtDateTime)
seEnd <- e ^. eEnd >>= (^. edtDateTime)
return SimpleEvent {..}
-- | A synonym representing the ID of a calendar. For mock calendars,
-- the ID @"busy"@ simulates busy events, otherwise they are available
-- time slots.
type CalendarId = Text
-- | Advance forward the specified number of days.
fwd :: Int -> Day -> Day
fwd n
| n <= 0 = id
| otherwise = fwd (n - 1) . succ
-- | Convert an HMM-formatted integer to the number of seconds. By HMM,
-- we mean like writing the time without the colon, so @215@ represents
-- 02:15 AM (== 8100 seconds) rather than 215 minutes == 3 hours and 35
-- minutes. This is only used for constructing the mock calendar.
toSec :: Int -> DiffTime
toSec hmm = fromInteger $ h * 3600 + m * 60
where
(h, m) = divMod (toInteger hmm) 100
-- | Construct a sample event for the mock calendar.
sampleEvent :: Day -> (Text, Day -> Day, Int, Int) -> SimpleEventUTC
sampleEvent d (summary, f, hmm1, hmm2) =
SimpleEvent
{ seSummary = summary
, seStart = UTCTime (f d) (toSec hmm1)
, seEnd = UTCTime (f d) (toSec hmm2)
}
-- | Fetch events from a single calendar.
listUpcoming ::
MonadResource m
=> Context
-> CalendarId
-> NominalDiffTime -- ^How far to look ahead
-> m [SimpleEventUTC]
listUpcoming (MockCxt d) cid _ =
return $
map (sampleEvent d) $
if cid == "busy"
then busy
else free
where
busy =
[ ("busy1a", fwd 0, 1210, 1300)
, ("busy1b", fwd 0, 1330, 1430)
, ("busy1c", fwd 0, 1500, 1550)
, ("busy1d", fwd 0, 1730, 1830)
, ("busy2a", fwd 1, 1130, 1215)
, ("busy2b", fwd 1, 1330, 1400)
, ("busy2c", fwd 1, 1430, 1500)
, ("busy2d", fwd 1, 1610, 1650)
, ("busy3a", fwd 2, 1100, 1400)
, ("busy3b", fwd 2, 1900, 2100)
]
free =
[ ("free1a", fwd 0, 1100, 1155)
, ("free1b", fwd 0, 1300, 1450)
, ("free1c", fwd 0, 1530, 1800)
, ("free2a", fwd 1, 1200, 1600)
, ("free2b", fwd 1, 1700, 1800)
, ("free3a", fwd 2, 1000, 1200)
, ("free3b", fwd 2, 1500, 1930)
]
listUpcoming (GoogleCxt env) cid lookahead = do
now <- liftIO getCurrentTime
let end = addUTCTime lookahead now
xs <-
Google.runGoogle env $
Google.send $ eventsList cid & elTimeMin .~ Just now & elTimeMax .~ Just end
return $ mapMaybe simplifyEvent $ xs ^. eveItems
-- | Convert an event into a local time zone.
applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
applyTz tz ev =
SimpleEvent
{ seSummary = seSummary ev
, seStart = utcToLocalTimeTZ tz (seStart ev)
, seEnd = utcToLocalTimeTZ tz (seEnd ev)
}
groupByDay :: [SimpleEventLocal] -> [[SimpleEventLocal]]
groupByDay = groupAllOn (localDay . seStart)
-- | Construct a stream of events that represent available times with
-- chunks of busy times removed. Requires that the event streams are
-- already ordered.
availMinusBusy ::
Ord t
=> [SimpleEvent t] -- ^Available times
-> [SimpleEvent t] -- ^Busy times
-> [SimpleEvent t] -- ^Remaining available times
availMinusBusy [] _ = []
availMinusBusy aa [] = aa
availMinusBusy (a:aa) (b:bb)
-- A ends before B starts, so keep A and consider next A
| seEnd a <= seStart b = a : availMinusBusy aa (b : bb)
-- B ends before A starts, so consider next B.
| seEnd b <= seStart a = availMinusBusy (a : aa) bb
-- A is contained within B, so omit A and consider next A
| seStart b <= seStart a && seEnd a <= seEnd b = availMinusBusy aa (b : bb)
-- B is contained wholly within A, so split A and consider next B
| seStart a < seStart b && seEnd b < seEnd a =
let a1 = a {seEnd = seStart b}
a2 = a {seStart = seEnd b}
in a1 : availMinusBusy (a2 : aa) bb
-- B overlaps beginning of A, so adjust A and consider next B
| seStart b <= seStart a && seEnd b <= seEnd a =
let a' = a {seStart = seEnd b}
in availMinusBusy (a' : aa) bb
-- B overlaps end of A, so keep truncated A and consider next A
| otherwise {-seStart a <= seStart b && seEnd a <= seEnd b-}
=
let a' = a {seEnd = seStart b}
in a' : availMinusBusy aa (b : bb)
-- | Simultaneously fetch two calendars and return the difference
-- between them.
listAvailMinusBusy ::
(MonadResource m, MonadUnliftIO m)
=> Context
-> CalendarId -- ^Calendar with available times
-> CalendarId -- ^Calendar with busy times
-> NominalDiffTime -- ^How far to look ahead
-> m [SimpleEventUTC]
listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
availT <- async $ listUpcoming cxt cidAvail lookahead
busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
availMinusBusy <$> waitAsync availT <*> waitAsync busyT
-- | Take a stream of available times and split them into slots exactly
-- N minutes long.
partitionSlots ::
Int -- ^How many minutes per slot?
-> [SimpleEventUTC]
-> [SimpleEventUTC]
partitionSlots _ [] = []
partitionSlots minutes evs = loop evs
where
dt = fromIntegral $ minutes * 60
loop [] = []
loop (e:es) =
let et = addUTCTime dt (seStart e)
in if et <= seEnd e
then e {seEnd = et} : loop (e {seStart = et} : es)
else loop es
......@@ -19,8 +19,6 @@ import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
import Import.NoFoundation as Pre
import qualified Network.Google as Google
import qualified Network.Google.Auth as Google
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import Yesod.Core.Types (Logger)
......@@ -128,7 +126,7 @@ instance Yesod App
asText "'Play', 'Helvetica Neue', Helvetica, Arial, sans-serif"
addScriptL (StaticR js_jquery_3_3_1_min_js)
"https://code.jquery.com/jquery-3.3.1.min.js"
[("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=")
[("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=")
,("crossorigin", "anonymous")
]
addScriptL (StaticR js_js_cookie_2_2_0_min_js)
......
module Handler.Comment where
import Import
postCommentR :: Handler Value
postCommentR =
error "The simple scaffolding does not support authentication or a database for storing comments"
......@@ -10,17 +10,9 @@
module Handler.Home where
import qualified Calendar as Cal
import Control.Lens ((^.))
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones (utcToLocalTimeTZ)
import Data.Time.Zones.All (toTZName)
import qualified Data.Time.Format as TF
import Import
import qualified Network.Google as Google
import Network.Google.AppsCalendar (calendarListList, clItems,
cleSummary)
import Text.Julius (RawJS (..))
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..),
renderBootstrap3)
apptLengthOptions :: Handler (OptionList ApptLength)
apptLengthOptions = do
......@@ -49,14 +41,14 @@ locationField = Field{..}
return $ case find ((== txt) . locId) locs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldView id name attrs val isReq = do
fieldView i _ attrs val _ = do
locs <- appLocations . appSettings <$> getYesod
[whamlet|
<div .form-group>
$forall loc <- locs
<div .radio>
<label>
<input id="#{id}-#{locId loc}" name=#{id} type=radio
<input ##{i}-#{locId loc}" name=#{i} type=radio
value=#{locId loc} :val == Right loc:checked
*{attrs}>
#{locDescr loc}
......@@ -77,6 +69,7 @@ instance PathPiece TimeFmt where
instance Default TimeFmt where
def = Time12h
timeFmtOptions :: Handler (OptionList TimeFmt)
timeFmtOptions = return $ OptionList
{ olReadExternal = fromPathPiece
, olOptions =
......@@ -147,21 +140,32 @@ getHomeR = do
getAvailR :: Handler Html
getAvailR = do
((qr, _), _) <- runFormGet queryForm
let
FormSuccess q = qr -- TODO
ds = [1..4] :: [Int]
ts =
if queryTimeFmt q == Time12h
then ["11:00 AM", "12:00 PM", "1:00 PM", "2:30 PM"]
else ["11:00", "12:00", "13:00", "14:30"] :: [Text]
slotV d t = tshow d <> "/" <> t
withUrlRenderer
[hamlet|
$forall d <- ds
<h4>Day #{tshow d}
$forall t <- ts
<button type=submit name=slot value="#{slotV d t}" .btn.btn-default.btn-small>#{t}
|]
case qr of
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
let evs2 = Cal.partitionSlots (apptLengthMinutes (queryApptLength q)) evs1
let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2
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)
withUrlRenderer
[hamlet|
$forall day <- evs'
$maybe firstSlot <- headMay day
<h4>#{showDate firstSlot}
<p .slot-choices>
$forall slot <- day
<button type=submit name=slot value="TBD" .btn.btn-default.btn-small>#{showTime slot}
|]
postConfirmR :: Handler Html
postConfirmR = do
......@@ -172,77 +176,3 @@ postConfirmR = do
<p>
#{tshow qr}
|]
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
oldgetHomeR :: Handler Html
oldgetHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission =
case result of
FormSuccess res -> Just res
_ -> Nothing
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm =
renderBootstrap3 BootstrapBasicForm $
FileForm <$> fileAFormReq "Choose a file" <*>
areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where
textSettings =
FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[("class", "form-control"), ("placeholder", "File description")]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
getCalListR :: Handler Html
getCalListR = do
(AppSettings{..}, cxt) <- (appSettings &&& appCalendarCxt) <$> getYesod
endUTC <- liftIO $ addUTCTime appLookahead <$> getCurrentTime
let endLocal = utcToLocalTimeTZ (tzByLabel appDefaultTimeZone) endUTC
xs <- Cal.listCalendars cxt
defaultLayout
[whamlet|
<h2>Hello calendar
<pre>appLocalAssets: #{appLocalAssets}
<pre>#{show endLocal}
<ol>
$forall x <- xs
<li>#{x}
|]
......@@ -36,7 +36,7 @@ import Yesod.Default.Util (WidgetFileSettings,
-- | Represent the valid appointment lengths, in minutes.
newtype ApptLength =
ApptLengthMinutes Int
ApptLengthMinutes { apptLengthMinutes :: Int }
deriving (Eq, Ord, Show)
instance FromJSON ApptLength where
......
This diff is collapsed.
......@@ -18,9 +18,3 @@
<div .row>
<div .col-md-12>
^{widget}
<!-- Footer -->
<footer .footer>
<div .container>
<p .text-muted>
#{appCopyright $ appSettings master}
......@@ -8,6 +8,10 @@
animation: glyphicon-spin-r 1s infinite linear;
}
.slot-choices button {
margin: 0 8px 10px 0;
}
@-webkit-keyframes glyphicon-spin-r {
0% {
-webkit-transform: rotate(0deg);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment