feat(users/Profpatsch/mailbox-org): init r/5560

A smol little tool to talk to the mailbox.org backend. This is handy
for eventually setting stuff like email filters. Their API is absolute
crap, but we’ll deal with it.

Updates the prelude & adds some pretty printing helpers.

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

3 files changed, 148 insertions, 0 deletions

diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs
new file mode 100644
index 000000000000..a7eab3305f6a
--- /dev/null
+++ b/users/Profpatsch/mailbox-org/MailboxOrg.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Main where
+
+import Control.Monad (replicateM)
+import Data.ByteString qualified as ByteString
+import Data.List qualified as List
+import MyPrelude
+import Network.HTTP.Conduit qualified as Client
+import Network.HTTP.Simple qualified as Client
+import Pretty
+import System.Exit qualified as Exit
+import System.Random qualified as Random
+import System.Random.Stateful qualified as Random
+import Prelude hiding (log)
+import Data.Aeson (Value)
+import Label
+import qualified System.Process as Proc
+import qualified Data.ByteString.Char8 as Char8
+
+secret :: IO (T2 "email" ByteString "password" ByteString)
+secret = do
+  T2
+    (label @"email" "mail@profpatsch.de")
+    <$> (label @"password" <$> fromPass "email/mailbox.org" )
+  where
+    fromPass name = Proc.readProcess "pass" [name] ""
+     <&> stringToText <&> textToBytesUtf8
+      <&> Char8.strip
+
+main :: IO ()
+main = run =<< secret
+
+
+run :: (HasField "email" dat ByteString,
+  HasField "password" dat ByteString) =>
+ dat -> IO ()
+run dat = do
+  session <- login dat
+  req <- Client.parseRequest "https://office.mailbox.org/appsuite/api/mailfilter/v2?action=list&columns=1"
+    <&> Client.setRequestMethod "PUT"
+    <&> addSession session
+  Client.httpJSON @_ @Value req
+    >>= okOrDie
+    <&> Client.responseBody
+    >>= printPretty
+
+newtype Session = Session Client.CookieJar
+
+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)
+  (req
+    & Client.addToRequestQueryString [("session", Just sessionId)])
+      { 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
+          Exit.die "non-200 result"
diff --git a/users/Profpatsch/mailbox-org/default.nix b/users/Profpatsch/mailbox-org/default.nix
new file mode 100644
index 000000000000..b9b0c0f5f41d
--- /dev/null
+++ b/users/Profpatsch/mailbox-org/default.nix
@@ -0,0 +1,16 @@
+{ depot, pkgs, lib, ... }:
+
+let
+  cas-serve = pkgs.writers.writeHaskell "mailbox-org"
+    {
+      libraries = [
+        depot.users.Profpatsch.my-prelude
+        pkgs.haskellPackages.aeson
+        pkgs.haskellPackages.http-conduit
+
+      ];
+      ghcArgs = [ "-threaded" ];
+    } ./MailboxOrg.hs;
+
+in
+cas-serve
diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal
new file mode 100644
index 000000000000..eab66242d4db
--- /dev/null
+++ b/users/Profpatsch/mailbox-org/mailbox-org.cabal
@@ -0,0 +1,20 @@
+cabal-version:      2.4
+name:               mailbox-org
+version:            0.1.0.0
+author:             Profpatsch
+maintainer:         mail@profpatsch.de
+
+executable mailbox-org
+    main-is: MailboxOrg.hs
+
+    build-depends:
+        base >=4.15 && <5,
+        my-prelude,
+        random,
+        http-conduit,
+        http-client,
+        aeson,
+        bytestring,
+        process
+
+    default-language: Haskell2010