diff options
Diffstat (limited to 'users/Profpatsch/parked')
17 files changed, 1290 insertions, 0 deletions
diff --git a/users/Profpatsch/parked/ical-smolify/IcalSmolify.hs b/users/Profpatsch/parked/ical-smolify/IcalSmolify.hs new file mode 100644 index 000000000000..77264d16937e --- /dev/null +++ b/users/Profpatsch/parked/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/parked/ical-smolify/README.md b/users/Profpatsch/parked/ical-smolify/README.md new file mode 100644 index 000000000000..86c166d3c179 --- /dev/null +++ b/users/Profpatsch/parked/ical-smolify/README.md @@ -0,0 +1,5 @@ +# ical-smolify + +Ensmallen an `ical` by stripping out redundant information like timezone definitions. + +The idea here was that after running through this preprocessor, it fits into a QR code (~2000bits) that can be scanned with your phone (for automatically adding to mobile calendar). diff --git a/users/Profpatsch/parked/ical-smolify/default.nix.inactive b/users/Profpatsch/parked/ical-smolify/default.nix.inactive new file mode 100644 index 000000000000..bf766db0e974 --- /dev/null +++ b/users/Profpatsch/parked/ical-smolify/default.nix.inactive @@ -0,0 +1,23 @@ +{ depot, pkgs, lib, ... }: + +let + ical-smolify = 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 + +ical-smolify.overrideAttrs (old: { + meta = lib.recursiveUpdate old.meta or { } { + # Dependency iCalendar no longer builds in nixpkgs due to a lack of maintenance upstream + # https://github.com/nixos/nixpkgs/commit/13d10cc6e302e7d5800c6a08c1728b14c3801e26 + ci.skip = true; + }; +}) diff --git a/users/Profpatsch/parked/ical-smolify/ical-smolify.cabal b/users/Profpatsch/parked/ical-smolify/ical-smolify.cabal new file mode 100644 index 000000000000..d7a46c581df2 --- /dev/null +++ b/users/Profpatsch/parked/ical-smolify/ical-smolify.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.0 +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 && <5, + my-prelude, + exec-helpers + data-default + case-insensitive + iCalendar + + default-language: Haskell2010 diff --git a/users/Profpatsch/parked/mailbox-org/MailboxOrg.hs b/users/Profpatsch/parked/mailbox-org/MailboxOrg.hs new file mode 100644 index 000000000000..6c5820080c76 --- /dev/null +++ b/users/Profpatsch/parked/mailbox-org/MailboxOrg.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wall #-} + +module Main where + +import Aeson (parseErrorTree) +import AesonQQ (aesonQQ) +import ArglibNetencode +import Control.Exception (try) +import Control.Monad (replicateM) +import Data.Aeson qualified as Json +import Data.Aeson.BetterErrors qualified as Json +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString qualified as ByteString +import Data.ByteString.Lazy qualified as Lazy +import Data.Char qualified as Char +import "pa-error-tree" Data.Error.Tree +import Data.Functor.Compose +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import ExecHelpers +import Label +import Netencode qualified +import Netencode.Parse qualified as NetParse +import Network.HTTP.Conduit qualified as Client +import Network.HTTP.Simple qualified as Client +import PossehlAnalyticsPrelude +import Pretty +import System.Directory qualified as File +import System.Environment qualified as Env +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import System.Exit qualified as Exit +import System.FilePath ((</>)) +import System.Process.Typed qualified as Process +import System.Random qualified as Random +import System.Random.Stateful qualified as Random +import Prelude hiding (log) + +secret :: Tools -> IO (T2 "email" ByteString "password" ByteString) +secret tools = do + T2 + (label @"email" "mail@profpatsch.de") + <$> (label @"password" <$> fromPass "email/mailbox.org") + where + fromPass name = + tools.pass & runToolExpect0 [name] + +progName :: CurrentProgramName +progName = "mailbox-org" + +log :: Error -> IO () +log err = do + putStderrLn (errorContext progName.unCurrentProgramName err & prettyError) + +data Tools = Tools + { pass :: Tool + } + deriving stock (Show) + +newtype Tool = Tool {unTool :: FilePath} + deriving stock (Show) + +parseTools :: Applicative m => (Text -> m (Either Error Tool)) -> m (Either ErrorTree Tools) +parseTools getTool = do + let parser = + ( do + pass <- get "pass" + pure Tools {..} + ) + parser & finalize + where + get name = name & getTool <&> eitherToListValidation & Compose + finalize p = + p.getCompose + <&> first (errorTree "Error reading tools") + <&> validationToEither + +main :: IO () +main = + arglibNetencode progName Nothing + >>= parseToolsArglib + >>= secret + >>= run applyFilters + +run :: + ( HasField "email" dat ByteString, + HasField "password" dat ByteString + ) => + (Session -> IO ()) -> + dat -> + IO () +run act loginData = do + session <- login loginData + act session + +listFilterConfig :: Session -> IO () +listFilterConfig session = do + mailfilter + session + "config" + mempty + (Json.key "data" Json.asObject) + () + >>= printPretty + +applyFilterRule :: + (HasField "folderId" dat Text) => + dat -> + Session -> + IO () +applyFilterRule dat session = do + mailfilter + session + "apply" + ( T2 + (label @"extraQueryParams" [("folderId", Just (dat.folderId & textToBytesUtf8))]) + mempty + ) + (Json.key "data" Json.asArray >> pure ()) + (Json.Object mempty) + +data FilterRule = FilterRule + { actioncmds :: NonEmpty Json.Object, + test :: NonEmpty Json.Object + } + +data MailfilterList = MailfilterList + { id_ :: Json.Value, + rulename :: Text + } + deriving stock (Show, Eq) + +simpleRule :: + ( HasField "rulename" r Text, + HasField "id" r Natural, + HasField "emailContains" r Text, + HasField "subjectStartsWith" r Text + ) => + r -> + Json.Value +simpleRule dat = do + [aesonQQ|{ + "id": |dat.id & enc @Natural|, + "position": 3, + "rulename": |dat.rulename & enc @Text|, + "active": true, + "flags": [], + "test": { + "id": "allof", + "tests": [ + { + "id": "from", + "comparison": "contains", + "values": [ + |dat.emailContains & enc @Text| + ] + }, + { + "id": "subject", + "comparison": "startswith", + "values": [ + |dat.subjectStartsWith & enc @Text| + ] + } + ] + }, + "actioncmds": [ + { + "id": "move", + "into": "default0/Archive" + }, + { + "id": "stop" + } + ] + }|] + where + enc :: forall a. Json.ToJSON a => a -> Lazy.ByteString + enc val = val & Json.toJSON & Json.encode + +applyFilters :: Session -> IO () +applyFilters session = do + filters <- + mailfilter + session + "list" + mempty + ( Json.key "data" $ do + ( Json.eachInArray $ asDat @"mailfilter" $ do + id_ <- Json.key "id" Json.asValue + rulename <- Json.key "rulename" Json.asText + pure MailfilterList {..} + ) + <&> mapFromListOn (\dat -> getLabel @"rulename" dat.parsed) + ) + ([] :: [()]) + let goal = Map.fromList [(label @"rulename" "another", 32 :: Integer), (label @"rulename" "xyz", 23)] + let actions = declarativeUpdate goal filters + log [fmt|To * create: {actions.toCreate & Map.keys & show}, * update: {actions.toUpdate & Map.keys & show}, * delete: {actions.toDelete & Map.keys & show}|] + +-- where +-- filters +-- & Map.elems +-- & traverse_ +-- ( updateIfDifferent +-- session +-- ( \el -> +-- pure $ +-- el.original.mailfilter +-- & KeyMap.insert "active" (Json.Bool False) +-- ) +-- (pure ()) +-- ) + +-- updateIfDifferent :: +-- forall label parsed. +-- ( HasField "id_" parsed Json.Value, +-- HasField "rulename" parsed Text +-- ) => +-- Session -> +-- (Dat label Json.Object parsed -> IO Json.Object) -> +-- Json.Parse Error () -> +-- Dat label Json.Object parsed -> +-- IO () +-- updateIfDifferent session switcheroo parser dat = do +-- new <- switcheroo dat +-- if new /= getField @label dat.original +-- then do +-- log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|] +-- mailfilter +-- session +-- "update" +-- mempty +-- parser +-- new +-- else do +-- log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|] + +-- | https://oxpedia.org/wiki/index.php?title=HTTP_API_MailFilter +mailfilter :: + ( Json.ToJSON a, + Show b + ) => + Session -> + ByteString -> + T2 + "extraQueryParams" + Client.Query + "httpMethod" + (Maybe ByteString) -> + Json.Parse Error b -> + a -> + IO b +mailfilter session action opts parser body = do + req <- + Client.parseRequest "https://office.mailbox.org/appsuite/api/mailfilter/v2" + <&> Client.setQueryString + ( [ ("action", Just action), + ("colums", Just "1") + ] + <> opts.extraQueryParams + ) + <&> Client.setRequestMethod (opts.httpMethod & fromMaybe "PUT") + <&> Client.setRequestBodyJSON body + <&> addSession session + req + & httpJSON [fmt|Cannot parse result for {req & prettyRequestShort}|] parser + >>= okOrDie + -- >>= (\resp -> printPretty resp >> pure resp) + <&> Client.responseBody + where + prettyRequestShort :: Client.Request -> Text + prettyRequestShort req = [fmt|request {req & Client.method}: {req & Client.host}{req & Client.path}{req & Client.queryString}|] + +-- | Given a goal and the actual state, return which elements to delete, update and create. +declarativeUpdate :: + Ord k => + -- | goal map + Map k a -> + -- | actual map + Map k b -> + T3 + "toCreate" + (Map k a) + "toDelete" + (Map k b) + "toUpdate" + (Map k a) +declarativeUpdate goal actual = + T3 + (label @"toCreate" $ goal `Map.difference` actual) + (label @"toDelete" $ actual `Map.difference` goal) + (label @"toUpdate" $ goal `Map.intersection` actual) + +newtype Session = Session Client.CookieJar + +httpJSON :: + Error -> + Json.Parse Error b -> + Client.Request -> + IO (Client.Response b) +httpJSON errMsg parser req = do + req + & Client.httpJSON @_ @Json.Value + >>= traverse + ( \val -> do + case val of + Json.Object obj + | "error" `KeyMap.member` obj + && "error_desc" `KeyMap.member` obj -> do + printPretty obj + diePanic' "Server returned above inline error" + _ -> pure () + val & Json.parseValue parser & \case + Left errs -> + errs + & parseErrorTree errMsg + & diePanic' + Right a -> pure a + ) + +data Dat label orig parsed = Dat + { original :: Label label orig, + parsed :: parsed + } + deriving stock (Show, Eq) + +asDat :: + forall label err m a. + Monad m => + Json.ParseT err m a -> + Json.ParseT err m (Dat label Json.Object a) +asDat parser = do + original <- label @label <$> Json.asObject + parsed <- parser + pure Dat {..} + +addSession :: Session -> Client.Request -> Client.Request +addSession (Session jar) req = do + let sessionId = + jar + & Client.destroyCookieJar + & List.find (\c -> "open-xchange-session-" `ByteString.isPrefixOf` c.cookie_name) + & annotate "The cookie jar did not contain an open-exchange-session-*" + & unwrapError + & (.cookie_value) + + let req' = req & Client.addToRequestQueryString [("session", Just sessionId)] + req' {Client.cookieJar = Just jar} + +-- | Log into the mailbox.org service, and return the session secret cookies. +login :: (HasField "email" dat ByteString, HasField "password" dat ByteString) => dat -> IO Session +login dat = do + rnd <- randomString + req <- + Client.parseRequest "https://office.mailbox.org/ajax/login" + <&> Client.setQueryString + [ ("action", Just "formlogin"), + ("authId", Just $ ("mbo-" <> rnd) & stringToText & textToBytesUtf8) + ] + <&> Client.urlEncodedBody + [ ("version", "Form+Login"), + ("autologin", "true"), + ("client", "open-xchange-appsuite"), + ("uiWebPath", "/appsuite/"), + ("login", dat.email), + ("password", dat.password) + ] + Client.httpNoBody req + >>= okOrDie + <&> Client.responseCookieJar + <&> Session + where + -- For some reason they want the client to pass a random string + -- which is used for the session?‽!? + randomString = do + gen <- Random.newIOGenM =<< Random.newStdGen + let chars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] + let len = 11 + Random.uniformRM (0, List.length chars - 1) gen + & replicateM len + <&> map (\index -> chars !! index) + +okOrDie :: Show a => Client.Response a -> IO (Client.Response a) +okOrDie resp = + case resp & Client.getResponseStatusCode of + 200 -> pure resp + _ -> do + printPretty resp + diePanic' "non-200 result" + +diePanic' :: ErrorTree -> IO a +diePanic' errs = errs & prettyErrorTree & diePanic progName + +-- | Parse the tools from the given arglib input, and check that the executables exist +parseToolsArglib :: Netencode.T -> IO Tools +parseToolsArglib t = do + let oneTool name = + NetParse.asText + <&> textToString + <&> ( \path -> + path + & File.getPermissions + <&> File.executable + <&> ( \case + False -> Left $ [fmt|Tool "{name}" is not an executable|] + True -> Right (Tool path) + ) + ) + let allTools = + parseTools (\name -> Compose $ NetParse.key name >>> oneTool name) + & getCompose + t + & NetParse.runParse + "test" + -- TODO: a proper ParseT for netencode values + ( NetParse.asRecord + >>> NetParse.key "BINS" + >>> NetParse.asRecord + >>> allTools + ) + & orDo diePanic' + & join @IO + >>= orDo (\errs -> errs & diePanic') + +-- | Just assume the tools exist by name in the environment. +parseToolsToolname :: IO Tools +parseToolsToolname = + parseTools + ( \name -> + checkInPath name <&> \case + False -> Left [fmt|"Cannot find "{name}" in PATH|] + True -> Right $ Tool (name & textToString) + ) + >>= orDo diePanic' + +checkInPath :: Text -> IO Bool +checkInPath name = do + Env.lookupEnv "PATH" + <&> annotate "No PATH set" + >>= orDo diePanic' + <&> stringToText + <&> Text.split (== ':') + <&> filter (/= "") + >>= traverse + ( \p -> + File.getPermissions ((textToString p) </> (textToString name)) + <&> File.executable + & try @IOError + >>= \case + Left _ioError -> pure False + Right isExe -> pure isExe + ) + <&> or + +orDo :: Applicative f => (t -> f a) -> Either t a -> f a +orDo f = \case + Left e -> f e + Right a -> pure a + +runTool :: [Text] -> Tool -> IO (Exit.ExitCode, ByteString) +runTool args tool = do + let bashArgs = prettyArgsForBash ((tool.unTool & stringToText) : args) + log [fmt|Running: $ {bashArgs}|] + Process.proc + tool.unTool + (args <&> textToString) + & Process.readProcessStdout + <&> second toStrictBytes + <&> second stripWhitespaceFromEnd + +-- | Like `runCommandExpect0`, run the given tool, given a tool accessor. +runToolExpect0 :: [Text] -> Tool -> IO ByteString +runToolExpect0 args tool = + tool & runTool args >>= \(ex, stdout) -> do + checkStatus0 tool.unTool ex + pure stdout + +-- | Check whether a command exited 0 or crash. +checkStatus0 :: FilePath -> ExitCode -> IO () +checkStatus0 executable = \case + ExitSuccess -> pure () + ExitFailure status -> do + diePanic' [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|] + +stripWhitespaceFromEnd :: ByteString -> ByteString +stripWhitespaceFromEnd = ByteString.reverse . ByteString.dropWhile (\w -> w == charToWordUnsafe '\n') . ByteString.reverse + +-- | Pretty print a command line in a way that can be copied to bash. +prettyArgsForBash :: [Text] -> Text +prettyArgsForBash = Text.intercalate " " . map simpleBashEscape + +-- | Simple escaping for bash words. If they contain anything that’s not ascii chars +-- and a bunch of often-used special characters, put the word in single quotes. +simpleBashEscape :: Text -> Text +simpleBashEscape t = do + case Text.find (not . isSimple) t of + Just _ -> escapeSingleQuote t + Nothing -> t + where + -- any word that is just ascii characters is simple (no spaces or control characters) + -- or contains a few often-used characters like - or . + isSimple c = + Char.isAsciiLower c + || Char.isAsciiUpper c + || Char.isDigit c + -- These are benign, bash will not interpret them as special characters. + || List.elem c ['-', '.', ':', '/'] + -- Put the word in single quotes + -- If there is a single quote in the word, + -- close the single quoted word, add a single quote, open the word again + escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'" diff --git a/users/Profpatsch/parked/mailbox-org/README.md b/users/Profpatsch/parked/mailbox-org/README.md new file mode 100644 index 000000000000..b84e7b59c130 --- /dev/null +++ b/users/Profpatsch/parked/mailbox-org/README.md @@ -0,0 +1,7 @@ +# mailbox-org + +Interfacing with the API of [https://mailbox.org/](). + +They use [open-xchange](https://www.open-xchange.com/resources/oxpedia) as their App Suite, so we have to work with/reverse engineer their weird API. + +Intended so I have a way of uploading Sieve rules into their system semi-automatically. diff --git a/users/Profpatsch/parked/mailbox-org/default.nix.inactive b/users/Profpatsch/parked/mailbox-org/default.nix.inactive new file mode 100644 index 000000000000..73bd28292dcc --- /dev/null +++ b/users/Profpatsch/parked/mailbox-org/default.nix.inactive @@ -0,0 +1,38 @@ +{ depot, pkgs, lib, ... }: + +let + mailbox-org = pkgs.haskellPackages.mkDerivation { + pname = "mailbox-org"; + version = "0.1.0"; + + src = depot.users.Profpatsch.exactSource ./. [ + ./mailbox-org.cabal + ./src/AesonQQ.hs + ./MailboxOrg.hs + ]; + + libraryHaskellDepends = [ + depot.users.Profpatsch.my-prelude + depot.users.Profpatsch.execline.exec-helpers-hs + depot.users.Profpatsch.arglib.netencode.haskell + pkgs.haskellPackages.pa-prelude + pkgs.haskellPackages.pa-label + pkgs.haskellPackages.pa-error-tree + pkgs.haskellPackages.aeson + pkgs.haskellPackages.http-conduit + pkgs.haskellPackages.aeson-better-errors + ]; + + isLibrary = false; + isExecutable = true; + license = lib.licenses.mit; + }; + + +in +lib.pipe mailbox-org [ + (x: (depot.nix.getBins x [ "mailbox-org" ]).mailbox-org) + (depot.users.Profpatsch.arglib.netencode.with-args "mailbox-org" { + BINS = depot.nix.getBins pkgs.dovecot_pigeonhole [ "sieve-test" ]; + }) +] diff --git a/users/Profpatsch/parked/mailbox-org/mailbox-org.cabal b/users/Profpatsch/parked/mailbox-org/mailbox-org.cabal new file mode 100644 index 000000000000..a1b041447bbb --- /dev/null +++ b/users/Profpatsch/parked/mailbox-org/mailbox-org.cabal @@ -0,0 +1,95 @@ +cabal-version: 3.0 +name: mailbox-org +version: 0.1.0.0 +author: Profpatsch +maintainer: mail@profpatsch.de + + +common common-options + ghc-options: + -Wall + -Wno-type-defaults + -Wunused-packages + -Wredundant-constraints + -fwarn-missing-deriving-strategies + + -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html + -- for a description of all these extensions + default-extensions: + -- Infer Applicative instead of Monad where possible + ApplicativeDo + + -- Allow literal strings to be Text + OverloadedStrings + + -- Syntactic sugar improvements + LambdaCase + MultiWayIf + + -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error + NoStarIsType + + -- Convenient and crucial to deal with ambiguous field names, commonly + -- known as RecordDotSyntax + OverloadedRecordDot + + -- does not export record fields as functions, use OverloadedRecordDot to access instead + NoFieldSelectors + + -- Record punning + RecordWildCards + + -- Improved Deriving + DerivingStrategies + DerivingVia + + -- Type-level strings + DataKinds + + -- to enable the `type` keyword in import lists (ormolu uses this automatically) + ExplicitNamespaces + + default-language: GHC2021 + + +library + import: common-options + + hs-source-dirs: src + + exposed-modules: + AesonQQ + + build-depends: + base >=4.15 && <5, + pa-prelude, + aeson, + PyF, + template-haskell + + + +executable mailbox-org + import: common-options + main-is: MailboxOrg.hs + + build-depends: + base >=4.15 && <5, + mailbox-org, + my-prelude, + pa-prelude, + pa-label, + pa-error-tree, + exec-helpers, + netencode, + text, + directory, + filepath, + arglib-netencode, + random, + http-conduit, + aeson, + aeson-better-errors, + bytestring, + typed-process, + containers, diff --git a/users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs b/users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs new file mode 100644 index 000000000000..2ac3d533aeaa --- /dev/null +++ b/users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module AesonQQ where + +import Data.Aeson qualified as Json +import Language.Haskell.TH.Quote (QuasiQuoter) +import PossehlAnalyticsPrelude +import PyF qualified +import PyF.Internal.QQ qualified as PyFConf + +aesonQQ :: QuasiQuoter +aesonQQ = + PyF.mkFormatter + "aesonQQ" + PyF.defaultConfig + { PyFConf.delimiters = Just ('|', '|'), + PyFConf.postProcess = \exp_ -> do + -- TODO: this does not throw an error at compilation time if the json does not parse + [| + case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp_) of + Left err -> error err + Right a -> a + |] + } diff --git a/users/Profpatsch/parked/reverse-haskell-deps/README.md b/users/Profpatsch/parked/reverse-haskell-deps/README.md new file mode 100644 index 000000000000..efc288cae4a9 --- /dev/null +++ b/users/Profpatsch/parked/reverse-haskell-deps/README.md @@ -0,0 +1,3 @@ +# reverse-haskell-deps + +Parse the HTML at `https://packdeps.haskellers.com/reverse` to get the data about Haskell package reverse dependencies in a structured way (they should just expose that as a json tbh). diff --git a/users/Profpatsch/parked/reverse-haskell-deps/ReverseHaskellDeps.hs b/users/Profpatsch/parked/reverse-haskell-deps/ReverseHaskellDeps.hs new file mode 100644 index 000000000000..0e18ce8a6b37 --- /dev/null +++ b/users/Profpatsch/parked/reverse-haskell-deps/ReverseHaskellDeps.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Data.ByteString qualified as ByteString +import Data.Either +import Data.List qualified as List +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified +import MyPrelude +import Numeric.Natural +import Text.HTML.TagSoup qualified as Tag +import Text.Nicify +import Text.Read qualified as Read + +parseNat :: Text -> Maybe Natural +parseNat = Read.readMaybe . textToString + +printNice :: Show a => a -> IO () +printNice = putStrLn . nicify . show + +type Tag = Tag.Tag Text + +main = do + reverseHtml <- readStdinUtf8 + printNice $ List.sortOn snd $ packagesAndReverseDeps reverseHtml + where + readStdinUtf8 = bytesToTextUtf8Lenient <$> ByteString.getContents + +-- | reads the table provided by https://packdeps.haskellers.com/reverse +-- figuring out all sections (starting with the link to the package name), +-- then figuring out the name of the package and the first column, +-- which is the number of reverse dependencies of the package +packagesAndReverseDeps :: Text -> [(Text, Natural)] +packagesAndReverseDeps reverseHtml = do + let tags = Tag.parseTags reverseHtml + let sections = Tag.partitions (isJust . reverseLink) tags + let sectionName [] = "<unknown section>" + sectionName (sect : _) = sect & reverseLink & fromMaybe "<unknown section>" + let sectionNames = map sectionName sections + mapMaybe + ( \(name :: Text, sect) -> do + reverseDeps <- firstNaturalNumber sect + pure (sectionPackageName name sect, reverseDeps) :: Maybe (Text, Natural) + ) + $ zip sectionNames sections + where + reverseLink = \case + Tag.TagOpen "a" attrs -> findMaybe attrReverseLink attrs + _ -> Nothing + + attrReverseLink = \case + ("href", lnk) -> + if + | "packdeps.haskellers.com/reverse/" `Text.isInfixOf` lnk -> Just lnk + | otherwise -> Nothing + _ -> Nothing + + sectionPackageName :: Text -> [Tag] -> Text + sectionPackageName sectionName = \case + (_ : Tag.TagText name : _) -> name + (_ : el : _) -> sectionName + xs -> sectionName + + firstNaturalNumber :: [Tag] -> Maybe Natural + firstNaturalNumber = + findMaybe + ( \case + Tag.TagText t -> parseNat t + _ -> Nothing + ) diff --git a/users/Profpatsch/parked/reverse-haskell-deps/default.nix.inactive b/users/Profpatsch/parked/reverse-haskell-deps/default.nix.inactive new file mode 100644 index 000000000000..b0a44420d793 --- /dev/null +++ b/users/Profpatsch/parked/reverse-haskell-deps/default.nix.inactive @@ -0,0 +1,32 @@ +{ depot, pkgs, ... }: + +# Parses https://packdeps.haskellers.com/reverse +# and outputs the amount of reverse dependencies of each hackage package. + +let + + rev = depot.nix.writeExecline "reverse-haskell-deps" { } [ + "pipeline" + [ + "${pkgs.curl}/bin/curl" + "-L" + "https://packdeps.haskellers.com/reverse" + ] + rev-hs + + ]; + + rev-hs = pkgs.writers.writeHaskell "revers-haskell-deps-hs" + { + libraries = [ + depot.users.Profpatsch.my-prelude + pkgs.haskellPackages.nicify-lib + pkgs.haskellPackages.tagsoup + ]; + ghcArgs = [ "-threaded" ]; + } + ./ReverseHaskellDeps.hs; + + +in +rev diff --git a/users/Profpatsch/parked/reverse-haskell-deps/reverse-haskell-deps.cabal b/users/Profpatsch/parked/reverse-haskell-deps/reverse-haskell-deps.cabal new file mode 100644 index 000000000000..4792f52adf25 --- /dev/null +++ b/users/Profpatsch/parked/reverse-haskell-deps/reverse-haskell-deps.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.0 +name: reverse-haskell-deps +version: 0.1.0.0 +author: Profpatsch +maintainer: mail@profpatsch.de + +library + exposed-modules: ReverseHaskellDeps.hs + + build-depends: + base >=4.15 && <5, + my-prelude, + tagsoup, + nicify-lib + + default-language: Haskell2010 diff --git a/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/README.md b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/README.md new file mode 100644 index 000000000000..e0a6aa2fb83b --- /dev/null +++ b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/README.md @@ -0,0 +1,3 @@ +# sync-abfall-ics-aichach-friedberg + +A small tool to sync the ICS files for the local trash collection times at https://abfallwirtschaft.lra-aic-fdb.de/ diff --git a/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/default.nix.inactive b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/default.nix.inactive new file mode 100644 index 000000000000..739274cb6f1b --- /dev/null +++ b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/default.nix.inactive @@ -0,0 +1,31 @@ +{ depot, pkgs, ... }: + +let + sync-to-dir = depot.users.Profpatsch.writers.python3 + { + name = "sync-ics-to-dir"; + libraries = (py: [ + py.httpx + py.icalendar + ]); + } ./sync-ics-to-dir.py; + + config = + depot.users.Profpatsch.importDhall.importDhall + { + root = ./..; + files = [ + "sync-abfall-ics-aichach-friedberg/ics-to-caldav.dhall" + "dhall/lib.dhall" + "ini/ini.dhall" + ]; + main = "sync-abfall-ics-aichach-friedberg/ics-to-caldav.dhall"; + deps = [ + ]; + } + depot.users.Profpatsch.ini.externs; + + + +in +{ inherit config; } diff --git a/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/ics-to-caldav.dhall b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/ics-to-caldav.dhall new file mode 100644 index 000000000000..2a7ac84979d2 --- /dev/null +++ b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/ics-to-caldav.dhall @@ -0,0 +1,139 @@ +let Ini = ../ini/ini.dhall + +let Lib = ../dhall/lib.dhall + +in \(Ini/externs : Ini.Externs) -> + let Vdirsyncer = + let StorageType = + < FileSystem : { path : Text, fileext : < ICS > } + | Http : { url : Text } + > + + let Collection = < FromA | FromB | Collection : Text > + + let Collections = + < Unspecified | TheseCollections : List Collection > + + let Storage = { storageName : Text, storage : StorageType } + + in { Storage + , StorageType + , Collection + , Collections + , Pair = + { pairName : Text + , a : Storage + , b : Storage + , collections : Collections + } + } + + let toIniSections + : Vdirsyncer.Pair -> Ini.Sections + = \(pair : Vdirsyncer.Pair) -> + let + -- we assume the names are [a-zA-Z_] + renderList = + \(l : List Text) -> + "[" + ++ Lib.Text/concatMapSep + ", " + Text + (\(t : Text) -> "\"${t}\"") + l + ++ "]" + + in let nv = \(name : Text) -> \(value : Text) -> { name, value } + + let mkStorage = + \(storage : Vdirsyncer.Storage) -> + { name = "storage ${storage.storageName}" + , value = + merge + { FileSystem = + \ ( fs + : { path : Text, fileext : < ICS > } + ) -> + [ nv "type" "filesystem" + , nv + "fileext" + (merge { ICS = ".ics" } fs.fileext) + , nv "path" fs.path + ] + , Http = + \(http : { url : Text }) -> + [ nv "type" "http", nv "url" http.url ] + } + storage.storage + } + + in [ { name = "pair ${pair.pairName}" + , value = + [ nv "a" pair.a.storageName + , nv "b" pair.b.storageName + , nv + "collections" + ( merge + { Unspecified = "none" + , TheseCollections = + \(colls : List Vdirsyncer.Collection) -> + renderList + ( Lib.List/map + Vdirsyncer.Collection + Text + ( \ ( coll + : Vdirsyncer.Collection + ) -> + merge + { FromA = "from a" + , FromB = "from b" + , Collection = + \(t : Text) -> t + } + coll + ) + colls + ) + } + pair.collections + ) + ] + } + , mkStorage pair.a + , mkStorage pair.b + ] + + in { example = + Ini/externs.renderIni + ( Ini.appendInis + ( Lib.List/map + Vdirsyncer.Pair + Ini.Ini + ( \(pair : Vdirsyncer.Pair) -> + { globalSection = [] : Ini.Section + , sections = toIniSections pair + } + ) + ( [ { pairName = "testPair" + , a = + { storageName = "mystor" + , storage = + Vdirsyncer.StorageType.FileSystem + { path = "./test-ics" + , fileext = < ICS >.ICS + } + } + , b = + { storageName = "mystor" + , storage = + Vdirsyncer.StorageType.Http + { url = "https://profpatsch.de" } + } + , collections = Vdirsyncer.Collections.Unspecified + } + ] + : List Vdirsyncer.Pair + ) + ) + ) + } diff --git a/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/sync-ics-to-dir.py b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/sync-ics-to-dir.py new file mode 100644 index 000000000000..4af3b9fb85ab --- /dev/null +++ b/users/Profpatsch/parked/sync-abfall-ics-aichach-friedberg/sync-ics-to-dir.py @@ -0,0 +1,133 @@ +# horrible little module that fetches ICS files for the local trash public service. +# +# It tries its best to not overwrite existing ICS files in case the upstream goes down +# or returns empty ICS files. +import sys +import httpx +import asyncio +import icalendar +from datetime import datetime +import syslog +import os.path + +# Internal id for the street (extracted from the ics download url) +ortsteil_id = "e9c32ab3-df25-4660-b88e-abda91897d7a" + +# They are using a numeric encoding to refer to different kinds of trash +fraktionen = { + "restmüll": "1", + "bio": "5", + "papier": "7", + "gelbe_tonne": "13", + "problemmüllsammlung": "20" +} + +def ics_url(year): + frakt = ','.join(fraktionen.values()) + return f'https://awido.cubefour.de/Customer/aic-fdb/KalenderICS.aspx?oid={ortsteil_id}&jahr={year}&fraktionen={frakt}&reminder=1.12:00' + +def fetchers_for_years(start_year, no_of_years_in_future): + """given a starting year, and a number of years in the future, + return the years for which to fetch ics files""" + current_year = datetime.now().year + max_year = current_year + no_of_years_in_future + return { + "passed_years": range(start_year, current_year), + "this_and_future_years": range(current_year, 1 + max_year) + } + +async def fetch_ics(c, url): + """fetch an ICS file from an URL""" + try: + resp = await c.get(url) + except Exception as e: + return { "ics_does_not_exist_exc": e } + + if resp.is_error: + return { "ics_does_not_exist": resp } + else: + try: + ics = icalendar.Calendar.from_ical(resp.content) + return { "ics": { "ics_parsed": ics, "ics_bytes": resp.content } } + except ValueError as e: + return { "ics_cannot_be_parsed": e } + +def ics_has_events(ics): + """Determine if there is any event in the ICS, otherwise we can assume it’s an empty file""" + for item in ics.walk(): + if isinstance(item, icalendar.Event): + return True + return False + +async def write_nonempty_ics(directory, year, ics): + # only overwrite if the new ics has any events + if ics_has_events(ics['ics_parsed']): + path = os.path.join(directory, f"{year}.ics") + with open(path, "wb") as f: + f.write(ics['ics_bytes']) + info(f"wrote ics for year {year} to file {path}") + else: + info(f"ics for year {year} was empty, skipping") + + +def main(): + ics_directory = os.getenv("ICS_DIRECTORY", None) + if not ics_directory: + critical("please set ICS_DIRECTORY") + start_year = int(os.getenv("ICS_START_YEAR", 2022)) + future_years = int(os.getenv("ICS_FUTURE_YEARS", 2)) + + years = fetchers_for_years(start_year, no_of_years_in_future=future_years) + + + async def go(): + async with httpx.AsyncClient(follow_redirects=True) as c: + info(f"fetching ics for passed years: {years['passed_years']}") + for year in years["passed_years"]: + match await fetch_ics(c, ics_url(year)): + case { "ics_does_not_exist_exc": error }: + warn(f"The ics for the year {year} is gone, error when requesting: {error} for url {ics_url(year)}") + case { "ics_does_not_exist": resp }: + warn(f"The ics for the year {year} is gone, server returned status {resp.status} for url {ics_url(year)}") + case { "ics_cannot_be_parsed": error }: + warn(f"The returned ICS could not be parsed: {error} for url {ics_url(year)}") + case { "ics": ics }: + info(f"fetched ics from {ics_url(year)}") + await write_nonempty_ics(ics_directory, year, ics) + case _: + critical("unknown case for ics result") + + + info(f"fetching ics for current and upcoming years: {years['this_and_future_years']}") + for year in years["this_and_future_years"]: + match await fetch_ics(c, ics_url(year)): + case { "ics_does_not_exist_exc": error }: + critical(f"The ics for the year {year} is not available, error when requesting: {error} for url {ics_url(year)}") + case { "ics_does_not_exist": resp }: + critical(f"The ics for the year {year} is not available, server returned status {resp.status} for url {ics_url(year)}") + case { "ics_cannot_be_parsed": error }: + critical(f"The returned ICS could not be parsed: {error} for url {ics_url(year)}") + case { "ics": ics }: + info(f"fetched ics from {ics_url(year)}") + await write_nonempty_ics(ics_directory, year, ics) + case _: + critical("unknown case for ics result") + + asyncio.run(go()) + +def info(msg): + syslog.syslog(syslog.LOG_INFO, msg) + +def critical(msg): + syslog.syslog(syslog.LOG_CRIT, msg) + sys.exit(1) + +def warn(msg): + syslog.syslog(syslog.LOG_WARNING, msg) + +def debug(msg): + syslog.syslog(syslog.LOG_DEBUG, msg) + + +if __name__ == "__main__": + main() |