Clean up, document Calendar

config/routes

@@ -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

config/settings.yml

@@ -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

src/Application.hs

@@ -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

src/Calendar.hs

@@ -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

src/Foundation.hs

@@ -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)

src/Handler/Comment.hs

-module Handler.Comment where
-
-import Import
-
-postCommentR :: Handler Value
-postCommentR =
-    error "The simple scaffolding does not support authentication or a database for storing comments"

src/Handler/Home.hs

@@ -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}
-            |]

src/Settings.hs

@@ -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

templates/default-layout.hamlet

@@ -18,9 +18,3 @@
     <div .row>
         <div .col-md-12>
             ^{widget}
-
-<!-- Footer -->
-<footer .footer>
-    <div .container>
-        <p .text-muted>
-            #{appCopyright $ appSettings master}

templates/step1.lucius

@@ -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);