From fb4b8ab5ec3f02ad2a932362907ef7685bf10f8f Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 5 Oct 2024 14:34:23 +0200 Subject: chore(users/Profpatsch): park mailbox-org MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit I should probably remove the default.nix files in these as well so they don’t get built on CI. Change-Id: I09764f2ee198ab4016a1649f1675f7c45d207b09 Reviewed-on: https://cl.tvl.fyi/c/depot/+/12580 Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- users/Profpatsch/cabal.project | 1 - users/Profpatsch/hie.yaml | 4 - users/Profpatsch/mailbox-org/MailboxOrg.hs | 523 --------------------- users/Profpatsch/mailbox-org/README.md | 7 - users/Profpatsch/mailbox-org/default.nix | 38 -- users/Profpatsch/mailbox-org/mailbox-org.cabal | 95 ---- users/Profpatsch/mailbox-org/src/AesonQQ.hs | 24 - users/Profpatsch/parked/mailbox-org/MailboxOrg.hs | 523 +++++++++++++++++++++ users/Profpatsch/parked/mailbox-org/README.md | 7 + users/Profpatsch/parked/mailbox-org/default.nix | 38 ++ .../parked/mailbox-org/mailbox-org.cabal | 95 ++++ users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs | 24 + 12 files changed, 687 insertions(+), 692 deletions(-) delete mode 100644 users/Profpatsch/mailbox-org/MailboxOrg.hs delete mode 100644 users/Profpatsch/mailbox-org/README.md delete mode 100644 users/Profpatsch/mailbox-org/default.nix delete mode 100644 users/Profpatsch/mailbox-org/mailbox-org.cabal delete mode 100644 users/Profpatsch/mailbox-org/src/AesonQQ.hs create mode 100644 users/Profpatsch/parked/mailbox-org/MailboxOrg.hs create mode 100644 users/Profpatsch/parked/mailbox-org/README.md create mode 100644 users/Profpatsch/parked/mailbox-org/default.nix create mode 100644 users/Profpatsch/parked/mailbox-org/mailbox-org.cabal create mode 100644 users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project index 26b618696923..aa8df174ac9b 100644 --- a/users/Profpatsch/cabal.project +++ b/users/Profpatsch/cabal.project @@ -5,7 +5,6 @@ packages: ./arglib/arglib-netencode.cabal ./execline/exec-helpers.cabal ./htmx-experiment/htmx-experiment.cabal - ./mailbox-org/mailbox-org.cabal ./cas-serve/cas-serve.cabal ./jbovlaste-sqlite/jbovlaste-sqlite.cabal ./whatcd-resolver/whatcd-resolver.cabal diff --git a/users/Profpatsch/hie.yaml b/users/Profpatsch/hie.yaml index 1b5ae942ad56..3b67e11b974a 100644 --- a/users/Profpatsch/hie.yaml +++ b/users/Profpatsch/hie.yaml @@ -14,10 +14,6 @@ cradle: component: "lib:htmx-experiment" - path: "./htmx-experiment/Main.hs" component: "htmx-experiment:exe:htmx-experiment" - - path: "./mailbox-org/src" - component: "lib:mailbox-org" - - path: "./mailbox-org/MailboxOrg.hs" - component: "mailbox-org:exe:mailbox-org" - path: "./cas-serve/CasServe.hs" component: "cas-serve:exe:cas-serve" - path: "./jbovlaste-sqlite/JbovlasteSqlite.hs" diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs deleted file mode 100644 index 6c5820080c76..000000000000 --- a/users/Profpatsch/mailbox-org/MailboxOrg.hs +++ /dev/null @@ -1,523 +0,0 @@ -{-# 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/mailbox-org/README.md b/users/Profpatsch/mailbox-org/README.md deleted file mode 100644 index b84e7b59c130..000000000000 --- a/users/Profpatsch/mailbox-org/README.md +++ /dev/null @@ -1,7 +0,0 @@ -# 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/mailbox-org/default.nix b/users/Profpatsch/mailbox-org/default.nix deleted file mode 100644 index 73bd28292dcc..000000000000 --- a/users/Profpatsch/mailbox-org/default.nix +++ /dev/null @@ -1,38 +0,0 @@ -{ 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/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal deleted file mode 100644 index a1b041447bbb..000000000000 --- a/users/Profpatsch/mailbox-org/mailbox-org.cabal +++ /dev/null @@ -1,95 +0,0 @@ -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/mailbox-org/src/AesonQQ.hs b/users/Profpatsch/mailbox-org/src/AesonQQ.hs deleted file mode 100644 index 2ac3d533aeaa..000000000000 --- a/users/Profpatsch/mailbox-org/src/AesonQQ.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# 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/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 b/users/Profpatsch/parked/mailbox-org/default.nix new file mode 100644 index 000000000000..73bd28292dcc --- /dev/null +++ b/users/Profpatsch/parked/mailbox-org/default.nix @@ -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 + |] + } -- cgit 1.4.1