Commit 4304191b authored by Christopher League's avatar Christopher League
Browse files

Expand ICS capability, incl other courses

parent ef90bebe
......@@ -11,6 +11,7 @@
module App.ByteStoreWorkDir
( module App.ByteStore,
WorkDirT,
runWorkDir,
)
where
......@@ -61,18 +62,18 @@ instance (MonadResource m, MonadThrow m, MonadUnliftIO m) => ByteStoreRW (WorkDi
p <- pathFor k
liftIO $ removeFile p `onNotExist` ()
runWorkDir :: WorkDirT m a -> FilePath -> m a
runWorkDir action =
runReaderT action . WorkDir
runWorkDir :: FilePath -> WorkDirT m a -> m a
runWorkDir fp action =
runReaderT action (WorkDir fp)
instance
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
RunStoreRO WorkDirT FilePath m
where
runStoreRO fp action = runWorkDir action fp
runStoreRO = runWorkDir
instance
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
RunStoreRW WorkDirT FilePath m
where
runStoreRW fp action = runWorkDir action fp
runStoreRW = runWorkDir
......@@ -90,7 +90,8 @@ mkYesodData
/ HomeR GET
/pandoc.css PandocStyleR GET
/favicon.ico FaviconR GET
/cs101.ics ScheduleR GET
/cs101.ics Schedule101R GET
/ics/#Text ScheduleR GET
/me ProfileR GET POST
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
......
......@@ -9,8 +9,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module App.Schedule
( getScheduleR,
( getSchedule101R,
getScheduleR,
texSchedule,
laTeX,
orgMode,
)
where
......@@ -21,7 +24,7 @@ import App.YamlStore
import Control.Monad.Trans.Resource
import Data.Aeson as Js
import Data.Function (on)
import Data.List (elem, zipWith3)
import Data.List (elem, zipWith)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
......@@ -35,23 +38,49 @@ import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))
import GHC.Generics
import Text.ICalendar
data ScheduleKey = ScheduleKey
data ScheduleKey
= ScheduleKey
{courseTag :: Text}
deriving (Eq, Show, Ord)
instance Key ScheduleKey where
keyDir = "course"
keyToFileName _ = "schedule.yaml"
keyToFileName ScheduleKey {..} =
convertString courseTag <> "-schedule.yaml"
keyFromFileName f =
guard (f == keyToFileName ScheduleKey) $> ScheduleKey
keyFromFileName =
map ScheduleKey . Text.stripSuffix "-schedule.yaml" . convertString
data Schedule
= Schedule
{ schTitle :: Text,
schStart :: TimeOfDay,
schDays :: Text,
schMeetings :: [Meeting]
}
deriving (Show, Generic)
schJsonOpts :: Js.Options
schJsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop 3
}
instance ToJSON Schedule where
toJSON = genericToJSON schJsonOpts
instance FromJSON Schedule where
parseJSON = genericParseJSON schJsonOpts
data Meeting
= Meeting
{ meetUnit :: Maybe Text,
meetTopic :: Maybe Text,
meetRead :: Maybe Text,
meetExam :: Maybe Text
meetExam :: Maybe Text,
meetDue :: Maybe Text
}
deriving (Show, Generic)
......@@ -64,31 +93,69 @@ numberUnits i (m : ms) =
Just u ->
m {meetUnit = Just ("Unit " <> show i <> ": " <> u)} : numberUnits (i + 1) ms
meetingTitle :: Int -> LazyText
meetingTitle i = "CS101 Meeting " <> show i
numberThingsDue :: Map Text Int -> [Meeting] -> [Meeting]
numberThingsDue _ [] = []
numberThingsDue nums (m : ms) =
case meetDue m of
Nothing ->
m : numberThingsDue nums ms
Just kind ->
m {meetDue = Just (Text.toTitle kind <> " " <> show i <> " due")}
: numberThingsDue new ms
where
i = fromMaybe 1 $ Map.lookup kind nums
new = Map.insert kind (i + 1) nums
icalTitleDescr :: Text -> Int -> Meeting -> (Text, Text)
icalTitleDescr course i Meeting {..} =
( course <> " Meeting " <> show i <> parens (dotSep [meetExam, meetDue]),
dotSep [meetUnit, meetTopic, ("Read " <>) <$> meetRead]
)
where
dotSep = Text.intercalate ". " . catMaybes
parens "" = ""
parens s = " (" <> s <> ")"
data TextFmt
= TextFmt
{ textit, textbf :: Text -> Text,
beginDescr, endDescr :: Text,
descrItem :: Text -> Text -> Text
}
meetingDescr :: Meeting -> LazyText
meetingDescr Meeting {..} =
convertString . Text.intercalate ". " $
catMaybes
[ meetUnit,
meetExam,
meetTopic,
(("Read " <>) <$> meetRead)
]
laTeX :: TextFmt
laTeX =
TextFmt
{ textit = \s -> "\\emph{" <> s <> "}",
textbf = \s -> "\\textbf{" <> s <> "}",
beginDescr = "\\begin{description}\n",
endDescr = "\\end{description}\n",
descrItem = \k v -> "\\item[" <> k <> "] " <> v
}
orgMode :: TextFmt
orgMode =
TextFmt
{ textit = \s -> "/" <> s <> "/",
textbf = \s -> "*" <> s <> "*",
beginDescr = "",
endDescr = "",
descrItem = \k v -> "- " <> k <> " :: " <> stripNL v
}
stripNL :: Text -> Text
stripNL = Text.replace "\n" " "
meetingTex :: Meeting -> Text
meetingTex Meeting {..} =
meetingTex :: TextFmt -> Meeting -> Text
meetingTex fmt Meeting {..} =
convertString . Text.intercalate ". " $
catMaybes
[ emph <$> meetUnit,
bf <$> meetExam,
[ textit fmt <$> meetUnit,
textbf fmt <$> meetExam,
meetTopic,
meetRead
meetRead,
textbf fmt <$> meetDue
]
where
emph s = "\\emph{" <> s <> "}"
bf s = "\\textbf{" <> s <> "}"
meetJsonOpts :: Js.Options
meetJsonOpts =
......@@ -103,7 +170,7 @@ instance ToJSON Meeting where
instance FromJSON Meeting where
parseJSON = genericParseJSON meetJsonOpts
instance YamlEntity ScheduleKey [Meeting]
instance YamlEntity ScheduleKey Schedule
instance ToContent VCalendar where
toContent = toContent . printICalendar def
......@@ -148,18 +215,6 @@ instance Default VEvent where
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
......@@ -167,15 +222,15 @@ classDuration =
classTZ :: IsString s => s
classTZ = "America/New_York"
mkClassMeeting :: UTCTime -> DateTime -> LazyText -> LazyText -> VEvent
mkClassMeeting now start title descr =
mkClassMeeting :: UTCTime -> DateTime -> (Text, Text) -> VEvent
mkClassMeeting now start (title, descr) =
def
{ veDTStamp = DTStamp now def,
veUID = UID ("cs101-mtg-" <> show (localDay (dateTimeFloating start))) def,
veLocation = Just (Location "Pratt 610" def def def),
veDTStart = Just (DTStartDateTime start def),
veSummary = Just (Summary title def def def),
veDescription = Just (Description descr def def def),
veSummary = Just (Summary (convertString title) def def def),
veDescription = Just (Description (convertString descr) def def def),
veDTEndDuration = Just (Right classDuration)
}
......@@ -218,7 +273,7 @@ holidaysS20 =
)
]
where
noClass s = "\\textbf{No class — " <> s <> "}"
noClass s = "No class — " <> s
finalsWeek :: Map DateKey Text
finalsWeek =
......@@ -226,38 +281,60 @@ finalsWeek =
[ (KeyInterval (fromGregorian 2020 5 6) (fromGregorian 2020 5 12), "Finals Week")
]
monWedS20 :: [DateTime]
monWedS20 =
map (\d -> ZonedDateTime (LocalTime d classStart) classTZ) (Set.toList days)
weekDayOf :: Day -> Int
weekDayOf d
| d == fromGregorian 2020 2 18 = 1 -- Follow Monday schedule
| otherwise = mondayStartWeek d ^. _2
classDays :: TimeOfDay -> [Int] -> [DateTime]
classDays startTime daysOfWeek =
map (\d -> ZonedDateTime (LocalTime d startTime) classTZ) (Set.toList days)
where
sem = Set.fromList [fromGregorian 2020 1 22 .. fromGregorian 2020 5 5]
holidays = Set.unions $ map flattenDateKey $ Map.keys holidaysS20
isClassDay d =
d == fromGregorian 2020 2 18
|| mondayStartWeek d ^. _2 `elem` [1, 3]
isClassDay d = weekDayOf d `elem` daysOfWeek
days = Set.filter isClassDay $ sem `Set.difference` holidays
fetchSchedule :: ByteStoreRO m => m [Meeting]
fetchSchedule =
numberUnits 1 <$> loadY ScheduleKey
getScheduleR :: Handler TypedContent
getScheduleR = do
scheduledDays :: Schedule -> [DateTime]
scheduledDays sch =
classDays (schStart sch) $
case schDays sch of
"MW" -> [1, 3]
_ -> []
-- Path is, e.g., /ics/cs164.ics
getScheduleR :: Text -> Handler TypedContent
getScheduleR file = do
tag <- Text.stripSuffix ".ics" file & maybeReturn notFound
sched <- runRo (loadMaybeY (ScheduleKey tag)) >>= maybeReturn notFound
now <- getCurrentTime
descrs <- map meetingDescr <$> runRo fetchSchedule
let titles = map meetingTitle [1 ..]
evts = zipWith3 (mkClassMeeting now) monWedS20 titles descrs
return $ toTypedContent def {vcEvents = eventMap evts, vcOther = calProps}
texSchedule :: IO ()
texSchedule = do
meetings <- runResourceT $ runStoreRO @WorkDirT @FilePath "data" fetchSchedule
let meetingMap =
let meets = numberUnits 1 $ numberThingsDue mempty $ schMeetings sched
blurbs = zipWith (icalTitleDescr tag) [1 ..] meets
evts = zipWith (mkClassMeeting now) (scheduledDays sched) blurbs
calName = Text.toUpper tag <> " Spring 2020"
props =
Set.fromList
[ OtherProperty "X-WR-CALNAME" (convertString calName) def,
OtherProperty "X-WR-CALDESC" (convertString (schTitle sched)) def,
OtherProperty "X-WR-TIMEZONE" classTZ def,
OtherProperty "X-PUBLISHED-TTL" "PT1H" def
]
return $ toTypedContent def {vcEvents = eventMap evts, vcOther = props}
getSchedule101R :: Handler TypedContent
getSchedule101R =
getScheduleR "cs101.ics"
texSchedule :: Text -> TextFmt -> IO ()
texSchedule tag fmt = do
sched <-
runResourceT $ runWorkDir "data" $ loadY (ScheduleKey tag)
let meets = numberUnits 1 $ numberThingsDue mempty $ schMeetings sched
meetMap =
Map.fromList $
zip (map dateKeyFromDT monWedS20) (map meetingTex meetings)
entryMap = Map.unions [meetingMap, holidaysS20, finalsWeek]
putStrLn @Text "\\section{Schedule}"
putStrLn @Text "\\begin{description}"
zip (map dateKeyFromDT (scheduledDays sched)) (map (meetingTex fmt) meets)
entryMap = Map.unions [meetMap, textbf fmt <$> holidaysS20, finalsWeek]
putStrLn $ beginDescr fmt
forM_ (Map.toList entryMap) \(key, txt) ->
putStrLn $ "\\item[" <> keyToTex key <> "] " <> txt
putStrLn @Text "\\end{description}"
putStrLn $ descrItem fmt (keyToTex key) txt
putStrLn $ endDescr fmt
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
import App.Prelude
import App.Schedule
import Data.String.Conversions
import System.Environment
import System.Exit
main :: IO ()
main = texSchedule
main = do
getArgs >>= \case
[tag, "tex"] -> texSchedule (convertString tag) laTeX
[tag, "org"] -> do
putStrLn @Text "* Schedule"
texSchedule (convertString tag) orgMode
_ ->
throwM $ ExitFailure 101
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