chore(users/Profpatsch): park mailbox-org r/8777

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 <mail@profpatsch.de>

5 files changed, 687 insertions, 0 deletions

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
+            |]
+      }