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 0000000000..a7eab3305f
--- /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 0000000000..b9b0c0f5f4
--- /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 0000000000..eab66242d4
--- /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