path: root/app/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Control.Monad (forM, forM_)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Char (toLower)
import Data.Default.Class (def)
import Data.Foldable (toList)
import Data.List (intercalate, sort, sortOn)
import Data.Maybe (catMaybes, isJust, listToMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Text.Lazy qualified as TL
import Data.Time
import Data.Time qualified as DT
import Data.Time.Calendar.WeekDate (toWeekDate)
import System.Directory
    ( doesDirectoryExist
    , listDirectory
    )
import System.FilePath
    ( (</>)
    , takeExtension
    )
import System.Environment (getArgs)
import Text.ICalendar
import Text.ICalendar qualified as ICal
import Text.Printf (printf)


--------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------

data Event = Event
    { eventStart       :: LocalTime
    , eventEnd         :: Maybe LocalTime
    , eventSummary     :: T.Text
    , eventDescription :: Maybe T.Text
    , eventLocation    :: Maybe T.Text
    , eventUrl         :: Maybe T.Text
    , eventRecurrence  :: Maybe Recur
    , eventExDates     :: Set Day
    }
    deriving (Show)


data EventOccurrence = EventOccurrence
    { occurrenceDate  :: Day
    , occurrenceEvent :: Event
    }


--------------------------------------------------------------------------------
-- Main
--------------------------------------------------------------------------------

main :: IO ()
main = do
    args <- getArgs

    case args of
        []     -> run Nothing
        [path] -> run (Just path)
        _      -> usage


run :: Maybe FilePath -> IO ()
run mPath = do
    today <- localDay . zonedTimeToLocalTime <$> getZonedTime

    events <- case mPath of
        Nothing   -> pure []
        Just path -> loadEvents path

    let viewStart =
            firstDayOfMonth (addMonths (-1) today)

        viewEnd =
            firstDayOfMonth (addMonths 2 today)

        occurrences =
            concatMap
                (expandEvent viewStart viewEnd)
                events

    putStr (renderThreeMonths today occurrences)

    -- TODO flags to show cal and/or agenda
    --renderAgenda today events


usage :: IO ()
usage =
    putStrLn "usage: hascal [FILE.ics]"


--------------------------------------------------------------------------------
-- Loading iCalendar files
--------------------------------------------------------------------------------

loadEvents :: FilePath -> IO [Event]
loadEvents path = do
    isDir <- doesDirectoryExist path

    if isDir
    then do
        paths <- findICSFiles path
        events <- concat <$> mapM loadICSFile paths
        pure (sortOn eventStart events)
    else
        loadICSFile path


findICSFiles :: FilePath -> IO [FilePath]
findICSFiles dir = do
    entries <- listDirectory dir

    fmap concat $
        forM entries $ \entry -> do
            let path = dir </> entry
            isDir <- doesDirectoryExist path

            if isDir
            then findICSFiles path
            else
                pure
                    [ path
                    | map toLower (takeExtension path) == ".ics"
                    ]


loadICSFile :: FilePath -> IO [Event]
loadICSFile path = do
    source <- BL.readFile path
    let cleaned = stripValarms source

    case parseICalendar def path cleaned of
        Left err -> do
            putStrLn ("hascal: " <> path <> ": " <> err)
            pure []

        Right (calendars, warnings) -> do
            mapM_
                (\warning ->
                    putStrLn
                        ("hascal: warning: " <> path <> ": " <> warning))
                warnings

            pure (concatMap calendarEvents calendars)


loadEventDirectory :: FilePath -> IO [Event]
loadEventDirectory directory = do
    names <- listDirectory directory

    let files =
            [ directory </> name
            | name <- names
            , map toLower (takeExtension name) == ".ics"
            ]

    events <- concat <$> mapM loadEventFile files

    pure (sortOn eventStart events)


loadEventFile :: FilePath -> IO [Event]
loadEventFile path = do
    contents <- BL.readFile path
    let cleaned = stripValarms contents

    case parseICalendar def path cleaned of
        Left err -> do
            putStrLn ("hascal: " <> path <> ": " <> err)
            pure []

        Right (calendars, warnings) -> do
            mapM_
                (putStrLn . ("hascal: warning: " <>))
                warnings

            pure (concatMap calendarEvents calendars)


stripValarms :: BL.ByteString -> BL.ByteString
stripValarms =
    BLC.unlines . go . map normalize . BLC.lines
  where
    go [] =
        []

    go (line : rest)
        | line == "BEGIN:VALARM" =
            go (dropAlarm rest)

        | otherwise =
            line : go rest

    dropAlarm [] =
        []

    dropAlarm (line : rest)
        | line == "END:VALARM" =
            rest

        | otherwise =
            dropAlarm rest

    normalize =
        BL.dropWhileEnd (== 13)  -- '\r'


calendarEvents :: VCalendar -> [Event]
calendarEvents =
    catMaybes . map toEvent . toList . vcEvents


mapMaybeVEvent :: [VEvent] -> [Event]
mapMaybeVEvent =
    catMaybes . map toEvent


toEvent :: VEvent -> Maybe Event
toEvent event = do
    start <- extractStart (veDTStart event)

    pure Event
        { eventStart       = start
        , eventEnd         = extractEnd (veDTEndDuration event)
        , eventSummary     = maybe "" (TL.toStrict . summaryValue) (veSummary event)
        , eventDescription = fmap (TL.toStrict . descriptionValue) (veDescription event)
        , eventLocation    = fmap (TL.toStrict . locationValue) (veLocation event)
        , eventUrl         = fmap (T.pack . show . urlValue) (veUrl event)
        , eventRecurrence  = rRuleValue <$> listToMaybe (toList (veRRule event))
        , eventExDates     = extractExDates (veExDate event)
        }


--------------------------------------------------------------------------------
-- iCalendar value extraction
--------------------------------------------------------------------------------

dateTimeToLocal :: DateTime -> LocalTime
dateTimeToLocal (FloatingDateTime t) =
    t

dateTimeToLocal (UTCDateTime t) =
    utcToLocalTime utc t

dateTimeToLocal (ZonedDateTime t _) =
    t


extractStart :: Maybe DTStart -> Maybe LocalTime
extractStart Nothing =
    Nothing

extractStart (Just (DTStartDateTime dt _)) =
    Just (dateTimeToLocal dt)

extractStart (Just (DTStartDate date _)) =
    Just (LocalTime (dateValue date) midnight)


extractEnd :: Maybe (Either DTEnd DurationProp) -> Maybe LocalTime
extractEnd (Just (Left dtEnd)) =
    Just (extractDTEnd dtEnd)

extractEnd _ =
    Nothing


extractDTEnd :: DTEnd -> LocalTime
extractDTEnd (DTEndDateTime dt _) =
    dateTimeToLocal dt

extractDTEnd (DTEndDate date _) =
    LocalTime (dateValue date) midnight


extractExDates :: Set ExDate -> Set Day
extractExDates =
    Set.fromList . concatMap extract . toList
  where
    extract (ExDates dates _) =
        map dateValue (Set.toList dates)

    extract (ExDateTimes dateTimes _) =
        map dateTimeDay (Set.toList dateTimes)


dateTimeDay :: DateTime -> Day
dateTimeDay (FloatingDateTime t) =
    localDay t

dateTimeDay (UTCDateTime t) =
    localDay (utcToLocalTime utc t)

dateTimeDay (ZonedDateTime t _) =
    localDay t


extractSummary :: Maybe Summary -> T.Text
extractSummary =
    maybe "" (TL.toStrict . summaryValue)


extractDescription :: Maybe Description -> Maybe T.Text
extractDescription =
    fmap (TL.toStrict . descriptionValue)


extractLocation :: Maybe Location -> Maybe T.Text
extractLocation =
    fmap (TL.toStrict . locationValue)


extractUrl :: Maybe URL -> Maybe T.Text
extractUrl =
    fmap (T.pack . show . urlValue)


--------------------------------------------------------------------------------
-- Recurrence expansion
--------------------------------------------------------------------------------

expandEvent :: Day -> Day -> Event -> [EventOccurrence]
expandEvent from to event =
    case eventRecurrence event of
        Nothing ->
            singleOccurrence

        Just recur ->
            map makeOccurrence $
                filter (not . excluded) $
                takeWhile (< to) $
                dropWhile (< from) $
                recurrenceDatesLimited recur (eventStartDay event)

  where
    singleOccurrence =
        [ EventOccurrence (eventStartDay event) event
        | eventStartDay event >= from
        , eventStartDay event < to
        ]

    makeOccurrence day =
        EventOccurrence day event

    excluded day =
        day `Set.member` eventExDates event

    eventStartDay =
        localDay . eventStart


recurrenceDates :: Recur -> Day -> [Day]
recurrenceDates recur start =
    case recurFreq recur of
        Daily   -> daily
        Weekly  -> weekly
        Monthly -> monthly
        Yearly  -> yearly

  where
    interval =
        max 1 (recurInterval recur)

    daily =
        [ addDays (fromIntegral (n * interval)) start
        | n <- [0 ..]
        ]

    weekly =
        weeklyOccurrences recur start interval

    monthly =
        monthlyOccurrences recur start interval

    yearly =
        yearlyOccurrences recur start interval


recurrenceDatesLimited :: Recur -> Day -> [Day]
recurrenceDatesLimited recur start =
    takeUntil $
        maybe dates (`take` dates) (recurCount recur)
  where
    dates =
        dropWhile (< start) $
            recurrenceDates recur start

    takeUntil =
        case recurUntil recur of
            Nothing ->
                id

            Just untilDay ->
                takeWhile (<= untilDay)


recurCount :: Recur -> Maybe Int
recurCount recur =
    case recurUntilCount recur of
        Just (Right count) -> Just count
        _                  -> Nothing


recurUntil :: Recur -> Maybe Day
recurUntil recur =
    case recurUntilCount recur of
        Just (Left (Left date)) ->
            Just (dateValue date)

        Just (Left (Right dateTime)) ->
            Just (dateTimeDay dateTime)

        _ ->
            Nothing


--------------------------------------------------------------------------------
-- Daily / weekly recurrence
--------------------------------------------------------------------------------

weeklyOccurrences :: Recur -> Day -> Int -> [Day]
weeklyOccurrences recur start interval =
    concatMap occurrencesInWeek [0 ..]

  where
    weekStart =
        startOfWeek (recurWkSt recur) start

    weekdays =
        if null (recurByDay recur)
        then
            [toICalWeekday (dayOfWeek start)]
        else
            map weekdayOf (recurByDay recur)

    occurrencesInWeek n =
        let base =
                addDays
                    (fromIntegral (n * 7 * interval))
                    weekStart
        in sort
            [ addDays
                (fromIntegral (weekdayOffsetFrom (recurWkSt recur) wd))
                base
            | wd <- weekdays
            ]


weekdayOf :: Either (Int, ICal.Weekday) ICal.Weekday -> ICal.Weekday
weekdayOf value =
    case value of
        Left (_, wd) -> wd
        Right wd     -> wd


--------------------------------------------------------------------------------
-- Monthly recurrence
--------------------------------------------------------------------------------

monthlyOccurrences :: Recur -> Day -> Int -> [Day]
monthlyOccurrences recur start interval =
    concatMap occurrencesInMonth [0 ..]

  where
    occurrencesInMonth n =
        let month =
                addMonths (n * interval) start
        in monthlyDates recur month start


monthlyDates :: Recur -> Day -> Day -> [Day]
monthlyDates recur monthStart originalStart
    | not (null (recurByMonthDay recur)) =
        mapMaybe (makeDay monthStart) (recurByMonthDay recur)

    | not (null (recurByDay recur)) =
        monthlyByDay recur monthStart

    | otherwise =
        let (_, _, d) =
                toGregorian originalStart
        in maybeToList (makeDay monthStart d)


monthlyByDay :: Recur -> Day -> [Day]
monthlyByDay recur monthStart =
    sort . catMaybes $
        map (monthlyWeekday monthStart) (recurByDay recur)


monthlyWeekday :: Day -> Either (Int, ICal.Weekday) ICal.Weekday -> Maybe Day
monthlyWeekday monthStart spec =
    case spec of
        Right wd ->
            nthWeekday monthStart wd 1

        Left (n, wd) ->
            nthWeekday monthStart wd n


nthWeekday :: Day -> ICal.Weekday -> Int -> Maybe Day
nthWeekday monthStart wd n
    | n > 0 =
        let first =
                fromGregorian y m 1

            offset =
                weekdayOffsetFrom
                    (toICalWeekday (dayOfWeek first))
                    wd

            day =
                1 + offset + 7 * (n - 1)

        in makeDay monthStart day

    | n < 0 =
        let last =
                fromGregorian
                    y
                    m
                    (gregorianMonthLength y m)

            offset =
                weekdayOffsetFrom
                    wd
                    (toICalWeekday (dayOfWeek last))

            day =
                gregorianMonthLength y m
                    - offset
                    + 7 * (n + 1)

        in makeDay monthStart day

    | otherwise =
        Nothing

  where
    (y, m, _) =
        toGregorian monthStart


allWeekdays :: Day -> ICal.Weekday -> [Day]
allWeekdays monthStart wd =
    takeWhile sameMonth $
        iterate (addDays 7) first
  where
    (year, month, _) =
        toGregorian monthStart

    first =
        addDays
            (fromIntegral
                (weekdayOffsetFrom
                    (toICalWeekday (dayOfWeek monthStart))
                    wd))
            monthStart

    sameMonth day =
        let (y, m, _) = toGregorian day
        in y == year && m == month


--------------------------------------------------------------------------------
-- Yearly recurrence
--------------------------------------------------------------------------------

yearlyOccurrences :: Recur -> Day -> Int -> [Day]
yearlyOccurrences recur start interval =
    concatMap occurrencesInYear [0 ..]

  where
    (startYear, startMonth, startDay) =
        toGregorian start

    occurrencesInYear n =
        let year =
                startYear + fromIntegral (n * interval)
        in yearlyDates
            recur
            year
            startMonth
            startDay


yearlyDates :: Recur -> Integer -> MonthOfYear -> Int -> [Day]
yearlyDates recur year originalMonth originalDay
    | not (null (recurByMonth recur)) =
        concatMap datesForMonth (recurByMonth recur)

    | otherwise =
        maybeToList $
            makeYearDay
                year
                originalMonth
                originalDay

  where
    datesForMonth month =
        if null (recurByMonthDay recur)
        then
            if null (recurByDay recur)
            then
                maybeToList
                    (makeYearDay year month originalDay)
            else
                yearlyByDay
                    year
                    month
                    (recurByDay recur)
        else
            catMaybes
                [ makeDay
                    (fromGregorian year month 1)
                    d
                | d <- recurByMonthDay recur
                ]


makeYearDay :: Integer -> MonthOfYear -> Int -> Maybe Day
makeYearDay year month day =
    makeDay
        (fromGregorian year month 1)
        day


yearlyByDay
    :: Integer
    -> MonthOfYear
    -> [Either (Int, ICal.Weekday) ICal.Weekday]
    -> [Day]
yearlyByDay year month specs =
    sort $
        concatMap expand specs
  where
    monthStart =
        fromGregorian year month 1

    expand (Left (n, wd)) =
        maybeToList $
            nthWeekday monthStart wd n

    expand (Right wd) =
        allWeekdays monthStart wd


--------------------------------------------------------------------------------
-- Calendar calculations
--------------------------------------------------------------------------------

addMonths :: Int -> Day -> Day
addMonths n day =
    let (y, m, d) =
            toGregorian day

        total =
            y * 12
                + fromIntegral m
                - 1
                + fromIntegral n

        y' =
            total `div` 12

        m' =
            fromIntegral (total `mod` 12) + 1

        d' =
            min d (gregorianMonthLength y' m')

    in fromGregorian y' m' d'


firstDayOfMonth :: Day -> Day
firstDayOfMonth day =
    let (y, m, _) = toGregorian day
    in fromGregorian y m 1


dayOfMonth :: Day -> Int
dayOfMonth day =
    let (_, _, d) =
            toGregorian day
    in d


monthOf :: Day -> Int
monthOf day =
    let (_, m, _) =
            toGregorian day
    in m


isoWeekNumber :: Day -> Int
isoWeekNumber day =
    let (_, week, _) =
            toWeekDate day
    in week


startOfWeek :: ICal.Weekday -> Day -> Day
startOfWeek first day =
    addDays
        (negate (fromIntegral offset))
        day
  where
    offset =
        weekdayOffsetFrom
            first
            (toICalWeekday (dayOfWeek day))


weekdayOffsetFrom :: ICal.Weekday -> ICal.Weekday -> Int
weekdayOffsetFrom first target =
    (fromEnum target - fromEnum first) `mod` 7


makeDay :: Day -> Int -> Maybe Day
makeDay monthStart d =
    let (y, m, _) =
            toGregorian monthStart

        maxDay =
            gregorianMonthLength y m

    in if d >= 1 && d <= maxDay
       then Just (fromGregorian y m d)
       else Nothing


maybeToList :: Maybe a -> [a]
maybeToList Nothing  = []
maybeToList (Just x) = [x]


toICalWeekday :: DayOfWeek -> Weekday
toICalWeekday dow =
    case dow of
        Data.Time.Monday ->
            Text.ICalendar.Monday

        Data.Time.Tuesday ->
            Text.ICalendar.Tuesday

        Data.Time.Wednesday ->
            Text.ICalendar.Wednesday

        Data.Time.Thursday ->
            Text.ICalendar.Thursday

        Data.Time.Friday ->
            Text.ICalendar.Friday

        Data.Time.Saturday ->
            Text.ICalendar.Saturday

        Data.Time.Sunday ->
            Text.ICalendar.Sunday


--------------------------------------------------------------------------------
-- Calendar rendering
--------------------------------------------------------------------------------


eventOnDay :: Day -> [EventOccurrence] -> Bool
eventOnDay date =
    any ((== date) . occurrenceDate)


renderThreeMonths :: Day -> [EventOccurrence] -> String
renderThreeMonths today occurrences =
    monthColor <> -- XXX this is a hack, we really want to colorize in renderMonth instead
    unlines
        [ intercalate " "
            [ padMonth month row
            | month <- monthLines
            ]
        | row <- [0 .. 7]
        ]

  where
    firstMonth =
        firstDayOfMonth today

    months =
        [ addMonths (-1) firstMonth
        , firstMonth
        , addMonths 1 firstMonth
        ]

    monthLines =
        map
            (renderMonth today occurrences)
            months


renderMonth :: Day -> [EventOccurrence] -> Day -> [String]
renderMonth today occurrences month =
    -- TODO colors interfer with padMonth
    -- TODO [ monthColor <> center 24 (formatMonth month) <> resetColor
    [ center 24 (formatMonth month)
    , "   " <> dayOfWeekColor <> "Mo Tu We Th Fr Sa Su" <> resetColor <> " "
    ]
    <> map
        (renderWeek today occurrences month)
        [0 .. 5]


renderWeek :: Day -> [EventOccurrence] -> Day -> Int -> String
renderWeek today occurrences monthDay week =
    weekNumber <> concatMap renderCell [0 .. 6]

  where
    first =
        firstDayOfMonth monthDay

    offset =
        weekdayOffsetFrom
            ICal.Monday
            (toICalWeekday (dayOfWeek first))

    firstDay =
        addDays
            (fromIntegral (week * 7 - offset))
            first

    dates =
        map
            (\weekday ->
                dayForPosition
                    first
                    offset
                    week
                    weekday)
            [0 .. 6]

    hasDays =
        any isJust dates

    weekNumber
        | hasDays =
            weekNumberColor
            <> printf "%02d" (isoWeekNumber firstActualDay)
            <> resetColor
            <> " "
        | otherwise =
            "   "

    firstActualDay =
        head (catMaybes dates)

    renderCell weekday =
        case dates !! weekday of
            Nothing ->
                "   "

            Just date ->
                colorize
                    today
                    occurrences
                    date
                    (printf "%2d" (dayOfMonth date))
                    <> " "


dayForPosition
    :: Day
    -> Int
    -> Int
    -> Int
    -> Maybe Day
dayForPosition first offset week weekday =
    let dayNumber =
            week * 7
                + weekday
                - offset
                + 1

        candidate =
            addDays
                (fromIntegral (dayNumber - 1))
                first

        (_, month, _) =
            toGregorian first

    in if dayNumber < 1
       || monthOf candidate /= month
       then Nothing
       else Just candidate


formatMonth :: Day -> String
formatMonth day =
    formatTime
        defaultTimeLocale
        "%B %Y"
        day


center :: Int -> String -> String
center width str =
    let padding =
            max 0 (width - length str)

        left =
            padding `div` 2

    in replicate left ' ' <> str


padRight :: Int -> String -> String
padRight width str =
    str
        <> replicate
            (max 0 (width - length str))
            ' '


padMonth :: [String] -> Int -> String
padMonth lines' row =
    case drop row lines' of
        (line : _) ->
            padRight 24 line

        [] ->
            replicate 24 ' '


--------------------------------------------------------------------------------
-- Colors
--------------------------------------------------------------------------------

todayColor :: String
todayColor =
    --"\ESC[1;39;4m"
    "\ESC[38;5;203;1m"


eventColor :: String
eventColor =
    "\ESC[1;36m"


pastColor :: String
pastColor =
    "\ESC[2m"


weekNumberColor :: String
weekNumberColor =
    "\ESC[38;5;241m"


dayOfWeekColor :: String
dayOfWeekColor =
    "\ESC[38;5;241m"


monthColor :: String
monthColor =
    "\ESC[38;5;241m"


resetColor :: String
resetColor =
    "\ESC[m"


colorize :: Day -> [EventOccurrence] -> Day -> String -> String
colorize today occurrences date text
    | date == today =
        todayColor <> text <> resetColor

    | eventOnDay date occurrences =
        eventColor <> text <> resetColor

    | date < today =
        pastColor <> text <> resetColor

    | otherwise =
        text


--------------------------------------------------------------------------------
-- Agenda
--------------------------------------------------------------------------------

renderAgenda :: Day -> [Event] -> IO ()
renderAgenda today events = do
    let viewStart =
            firstDayOfMonth (addMonths (-1) today)

        viewEnd =
            firstDayOfMonth (addMonths 2 today)

        relevant =
            filter
                (\e ->
                    let d =
                            localDay (eventStart e)
                    in d >= viewStart
                       && d < viewEnd)
                events

    forM_ relevant $ \event -> do
        let time =
                formatTime
                    defaultTimeLocale
                    "%a %d %H:%M"
                    (eventStart event)

        TIO.putStrLn
            (T.pack time
                <> "  "
                <> eventSummary event)

        forM_ (eventDescription event) $ \description ->
            TIO.putStrLn
                ("          " <> description)

        forM_ (eventLocation event) $ \location ->
            TIO.putStrLn
                ("          @ " <> location)

        forM_ (eventUrl event) $ \url ->
            TIO.putStrLn
                ("          " <> url)