Commit 442edfda authored by Christopher League's avatar Christopher League
Browse files

Generate .ics for meeting dates

parent 6536c6d5
......@@ -90,6 +90,7 @@ mkYesodData
/ HomeR GET
/pandoc.css PandocStyleR GET
/favicon.ico FaviconR GET
/cs101.ics ScheduleR GET
/me ProfileR GET POST
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
......
......@@ -23,6 +23,7 @@ import App.Page
import App.Post
import App.Prelude
import App.Profile
import App.Schedule
import App.User
import App.YamlStore
import Conduit
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module App.Schedule
( getScheduleR,
)
where
import App.ByteStoreWorkDir
import App.Foundation
import App.Prelude
import App.YamlStore
import Control.Lens (Lens')
import Data.Aeson as Js
import Data.List (elem, zipWith3)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.String (IsString)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..), fromGregorian)
import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
import Data.Time.Clock (UTCTime (..))
import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))
import GHC.Generics
import Text.ICalendar
data ScheduleKey = ScheduleKey
deriving (Eq, Show, Ord)
instance Key ScheduleKey where
keyDir = "course"
keyToFileName _ = "schedule.yaml"
keyFromFileName f =
guard (f == keyToFileName ScheduleKey) $> ScheduleKey
data Meeting
= Meeting
{ meetUnit :: Maybe Text,
meetTopic :: Maybe Text,
meetRead :: Maybe Text
}
deriving (Show, Generic)
numberUnits :: Int -> [Meeting] -> [Meeting]
numberUnits _ [] = []
numberUnits i (m : ms) =
case meetUnit m of
Nothing ->
m : numberUnits i ms
Just u ->
m {meetUnit = Just ("Unit " <> show i <> ": " <> u)} : numberUnits (i + 1) ms
meetingTitle :: Int -> LazyText
meetingTitle i = "Meeting " <> show i
meetingDescr :: Meeting -> LazyText
meetingDescr Meeting {..} =
convertString . Text.intercalate ". " $
catMaybes [meetUnit, meetTopic, (("Read " <>) <$> meetRead)]
-- meetingSummaryDescr index Meeting{..} =
-- ( "Meeting " <> show index,
-- ev &
-- veSummaryL ?~ Summary ("Meeting " <> show index) def def def
meetJsonOpts :: Js.Options
meetJsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop 4
}
instance ToJSON Meeting where
toJSON = genericToJSON meetJsonOpts
instance FromJSON Meeting where
parseJSON = genericParseJSON meetJsonOpts
instance YamlEntity ScheduleKey [Meeting]
instance ToContent VCalendar where
toContent = toContent . printICalendar def
instance ToTypedContent VCalendar where
toTypedContent =
TypedContent "text/calendar; charset=utf-8" . toContent
instance Default VEvent where
def =
VEvent
{ veUID = UID "" def,
veDTStamp = DTStamp (UTCTime (ModifiedJulianDay 0) 0) def,
veDTStart = Nothing,
veSummary = Nothing,
veDescription = Nothing,
veDTEndDuration = Nothing,
veClass = def,
veCreated = Nothing,
veGeo = Nothing,
veLastMod = Nothing,
veLocation = Nothing,
veOrganizer = Nothing,
vePriority = def,
veSeq = def,
veStatus = Nothing,
veTransp = def,
veUrl = Nothing,
veRecurId = Nothing,
veRRule = mempty,
veAttach = mempty,
veAttendee = mempty,
veCategories = mempty,
veComment = mempty,
veContact = mempty,
veExDate = mempty,
veRStatus = mempty,
veRelated = mempty,
veResources = mempty,
veRDate = mempty,
veAlarms = mempty,
veOther = mempty
}
calProps :: Set OtherProperty
calProps =
Set.fromList
[ OtherProperty "X-WR-CALNAME" "CS101 Spring 2020" def,
OtherProperty "X-WR-CALDESC" "Fundamentals of Computer and Information Sciences" def,
OtherProperty "X-WR-TIMEZONE" classTZ def,
OtherProperty "X-PUBLISHED-TTL" "PT1H" def
]
classStart :: TimeOfDay
classStart = TimeOfDay 9 0 0
classDuration :: DurationProp
classDuration =
DurationProp (DurationTime def 1 50 0) def
classTZ :: IsString s => s
classTZ = "America/New_York"
veStampL :: Lens' VEvent UTCTime
veStampL =
(\f ev -> f (veDTStamp ev) <&> \x -> ev {veDTStamp = x})
. (\f st -> f (dtStampValue st) <&> \x -> st {dtStampValue = x})
veUIDL :: Lens' VEvent LazyText
veUIDL =
(\f ev -> f (veUID ev) <&> \x -> ev {veUID = x})
. (\f uid -> f (uidValue uid) <&> \x -> uid {uidValue = x})
veDTStartL :: Lens' VEvent (Maybe DTStart)
veDTStartL f ev =
f (veDTStart ev) <&> \x -> ev {veDTStart = x}
veSummaryL :: Lens' VEvent (Maybe Summary)
veSummaryL f ev =
f (veSummary ev) <&> \x -> ev {veSummary = x}
veDescrL :: Lens' VEvent (Maybe Description)
veDescrL f ev =
f (veDescription ev) <&> \x -> ev {veDescription = x}
veEndDurL :: Lens' VEvent (Maybe (Either DTEnd DurationProp))
veEndDurL f ev =
f (veDTEndDuration ev) <&> \x -> ev {veDTEndDuration = x}
mkClassMeeting :: UTCTime -> DateTime -> LazyText -> LazyText -> VEvent
mkClassMeeting now start title descr =
def
& veStampL .~ now
& veUIDL .~ "cs101-mtg-" <> show (localDay (dateTimeFloating start))
& veDTStartL ?~ DTStartDateTime start def
& veSummaryL ?~ Summary title def def def
& veDescrL ?~ Description descr def def def
& veEndDurL ?~ Right classDuration
eventMap :: Ord a => [VEvent] -> Map (LazyText, Maybe a) VEvent
eventMap =
Map.fromList . map (\e -> ((uidValue (veUID e), Nothing), e))
monWedS20 :: [DateTime]
monWedS20 =
map (\d -> ZonedDateTime (LocalTime d classStart) classTZ) (Set.toList days)
where
sem = Set.fromList [fromGregorian 2020 1 22 .. fromGregorian 2020 5 5]
sprBrk = Set.fromList [fromGregorian 2020 3 9 .. fromGregorian 2020 3 15]
prezDay = Set.singleton (fromGregorian 2020 2 17)
holidays = sprBrk `Set.union` prezDay
isClassDay d =
d == fromGregorian 2020 2 18
|| mondayStartWeek d ^. _2 `elem` [1, 3]
days = Set.filter isClassDay $ sem `Set.difference` holidays
getScheduleR :: Handler TypedContent
getScheduleR = do
now <- getCurrentTime
descrs <- map meetingDescr . numberUnits 1 <$> runRo (loadY ScheduleKey)
let titles = map meetingTitle [1 ..]
evts = zipWith3 (mkClassMeeting now) monWedS20 titles descrs
return $ toTypedContent def {vcEvents = eventMap evts, vcOther = calProps}
{ mkDerivation, aeson, base, blaze-html, bytestring
, case-insensitive, conduit, containers, cryptohash, data-default
, directory, exceptions, extra, filelock, filepath, ghc-lib-parser
, gitlib, gitlib-libgit2, hashable, hpack, lens, mime-mail
, mime-types, mtl, pandoc, path-pieces, shakespeare, smtp-mail
, stdenv, string-conversions, tagged, text, time, transformers
, unix, unliftio, unordered-containers, yaml, yesod, yesod-auth
, yesod-core, yesod-form
, gitlib, gitlib-libgit2, hashable, hpack, iCalendar, lens
, mime-mail, mime-types, mtl, pandoc, path-pieces, resourcet
, shakespeare, smtp-mail, stdenv, string-conversions, tagged, text
, time, transformers, unix, unliftio, unordered-containers, yaml
, yesod, yesod-auth, yesod-core, yesod-form
}:
mkDerivation {
pname = "cms101";
......@@ -18,10 +18,10 @@ mkDerivation {
aeson base blaze-html bytestring case-insensitive conduit
containers cryptohash data-default directory exceptions extra
filelock filepath ghc-lib-parser gitlib gitlib-libgit2 hashable
lens mime-mail mime-types mtl pandoc path-pieces shakespeare
smtp-mail string-conversions tagged text time transformers unix
unliftio unordered-containers yaml yesod yesod-auth yesod-core
yesod-form
iCalendar lens mime-mail mime-types mtl pandoc path-pieces
resourcet shakespeare smtp-mail string-conversions tagged text time
transformers unix unliftio unordered-containers yaml yesod
yesod-auth yesod-core yesod-form
];
prePatch = "hpack";
license = "unknown";
......
......@@ -23,6 +23,7 @@ executable:
- gitlib
- gitlib-libgit2
- hashable
- iCalendar
- lens
- mime-mail
- mime-types
......
Supports Markdown
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