feat(users/Profpatsch): init ical-smolify r/4880

ical, but smol

to fit in qr

Change-Id: I37f99a20cfc96b85778a097b7c4f70923f026cd4
Reviewed-on: https://cl.tvl.fyi/c/depot/+/6617
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

3 files changed, 158 insertions, 0 deletions

diff --git a/users/Profpatsch/ical-smolify/IcalSmolify.hs b/users/Profpatsch/ical-smolify/IcalSmolify.hs
new file mode 100644
index 0000000000..77264d1693
--- /dev/null
+++ b/users/Profpatsch/ical-smolify/IcalSmolify.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Main where
+
+import qualified Data.ByteString.Lazy as Bytes.Lazy
+import qualified Data.CaseInsensitive as CaseInsensitive
+import qualified Data.Default as Default
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import ExecHelpers (dieUserError, CurrentProgramName)
+import MyPrelude
+import qualified System.Environment as Env
+import Text.ICalendar
+import Prelude hiding (log)
+
+main :: IO ()
+main = do
+  Env.getArgs >>= \case
+    [] -> dieUserError progName "First argument must be the ics file name"
+    (file : _) ->
+      do
+        parse file
+        >>= traverse_
+          ( \vcal ->
+              vcal
+                & stripSingleTimezone
+                & minify
+                & printICalendar Default.def
+                & Bytes.Lazy.putStr
+          )
+
+progName :: CurrentProgramName
+progName = "ical-smolify"
+
+log :: Error -> IO ()
+log err = do
+  putStderrLn (errorContext "ical-smolify" err & prettyError)
+
+parse :: FilePath -> IO [VCalendar]
+parse file = do
+  parseICalendarFile Default.def file >>= \case
+    Left err -> do
+      dieUserError progName [fmt|Cannot parse ical file: {err}|]
+    Right (cals, warnings) -> do
+      for_ warnings (\warn -> log [fmt|Warning: {warn}|])
+      pure cals
+
+-- | Converts a single timezone definition to the corresponding X-WR-Timezone field.
+stripSingleTimezone :: VCalendar -> VCalendar
+stripSingleTimezone vcal =
+  case vcal & vcTimeZones & Map.toList of
+    [] -> vcal
+    [(_, tz)] -> do
+      let xtz =
+            OtherProperty
+              { otherName = CaseInsensitive.mk "X-WR-TIMEZONE",
+                otherValue = tz & vtzId & tzidValue & textToBytesUtf8Lazy,
+                otherParams = OtherParams Set.empty
+              }
+      vcal
+        { vcOther =
+            vcal & vcOther
+              -- remove any existing x-wr-timezone fields
+              & Set.filter (\prop -> (prop & otherName) /= (xtz & otherName))
+              & Set.insert xtz,
+          vcTimeZones = Map.empty
+        }
+    _more -> vcal
+
+-- | Minify the vcalendar event by throwing away everything that’s not an event.
+minify :: VCalendar -> VCalendar
+minify vcal =
+  vcal
+    { vcProdId = ProdId "" (OtherParams Set.empty),
+      -- , vcVersion    :: ICalVersion
+      -- , vcScale      :: Scale
+      -- , vcMethod     :: Maybe Method
+      -- , vcOther      :: …
+      -- , vcTimeZones  :: Map Text VTimeZone
+      vcEvents = Map.map minifyEvent (vcal & vcEvents),
+      vcTodos = Map.empty,
+      vcJournals = Map.empty,
+      vcFreeBusys = Map.empty,
+      vcOtherComps = Set.empty
+    }
+
+minifyEvent :: VEvent -> VEvent
+minifyEvent vev =
+  vev
+--  { veDTStamp       :: DTStamp
+--   , veUID           :: UID
+--   , veClass         :: Class -- ^ 'def' = 'Public'
+--   , veDTStart       :: Maybe DTStart
+--   , veCreated       :: Maybe Created
+--   , veDescription   :: Maybe Description
+--   , veGeo           :: Maybe Geo
+--   , veLastMod       :: Maybe LastModified
+--   , veLocation      :: Maybe Location
+--   , veOrganizer     :: Maybe Organizer
+--   , vePriority      :: Priority -- ^ 'def' = 0
+--   , veSeq           :: Sequence -- ^ 'def' = 0
+--   , veStatus        :: Maybe EventStatus
+--   , veSummary       :: Maybe Summary
+--   , veTransp        :: TimeTransparency -- ^ 'def' = 'Opaque'
+--   , veUrl           :: Maybe URL
+--   , veRecurId       :: Maybe RecurrenceId
+--   , veRRule         :: Set RRule
+--   , veDTEndDuration :: Maybe (Either DTEnd DurationProp)
+--   , veAttach        :: Set Attachment
+--   , veAttendee      :: Set Attendee
+--   , veCategories    :: Set Categories
+--   , veComment       :: Set Comment
+--   , veContact       :: Set Contact
+--   , veExDate        :: Set ExDate
+--   , veRStatus       :: Set RequestStatus
+--   , veRelated       :: Set RelatedTo
+--   , veResources     :: Set Resources
+--   , veRDate         :: Set RDate
+--   , veAlarms        :: Set VAlarm
+--   , veOther         :: Set OtherProperty
+--   }
diff --git a/users/Profpatsch/ical-smolify/default.nix b/users/Profpatsch/ical-smolify/default.nix
new file mode 100644
index 0000000000..f67d175ce3
--- /dev/null
+++ b/users/Profpatsch/ical-smolify/default.nix
@@ -0,0 +1,16 @@
+{ depot, pkgs, lib, ... }:
+
+let
+  cas-serve = pkgs.writers.writeHaskell "ical-smolify"
+    {
+      libraries = [
+        pkgs.haskellPackages.iCalendar
+        depot.users.Profpatsch.my-prelude
+        depot.users.Profpatsch.execline.exec-helpers-hs
+
+      ];
+      ghcArgs = [ "-threaded" ];
+    } ./IcalSmolify.hs;
+
+in
+cas-serve
diff --git a/users/Profpatsch/ical-smolify/ical-smolify.cabal b/users/Profpatsch/ical-smolify/ical-smolify.cabal
new file mode 100644
index 0000000000..6a1bb6ea87
--- /dev/null
+++ b/users/Profpatsch/ical-smolify/ical-smolify.cabal
@@ -0,0 +1,18 @@
+cabal-version:      2.4
+name:               ical-smolify
+version:            0.1.0.0
+author:             Profpatsch
+maintainer:         mail@profpatsch.de
+
+executable ical-smolify
+    main-is: IcalSmolify.hs
+
+    build-depends:
+        base ^>=4.15.1.0,
+        my-prelude,
+        exec-helpers
+        data-default
+        case-insensitive
+        iCalendar
+
+    default-language: Haskell2010