feat(users/Profpatsch/mailbox-org): list & update filters r/5562

One step closer towards a declarative description of filters.
In the end, the filters should be updated by their `rulename` field.

This implements a simple scheme where we list all filters, parse some
of their fields, use those fields to determine whether we want to
change the filters, and then only update the filters where we changed
something.

Unfortunately, we can only update the filters one-by-one (a common
mistake in APIs).

Pulls in some modules for Json parsing that I like to use, and an
`ErrorTree` abstraction over `Error` and `Data.Tree`.

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

3 files changed, 169 insertions, 39 deletions

diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs
index a7eab3305f6a..80222dbb0dc1 100644
--- a/users/Profpatsch/mailbox-org/MailboxOrg.hs
+++ b/users/Profpatsch/mailbox-org/MailboxOrg.hs
@@ -1,56 +1,187 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -Wall #-}
 
 module Main where
 
+import Aeson (parseErrorTree)
 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.Char8 qualified as Char8
+import Data.Error.Tree (prettyErrorTree)
 import Data.List qualified as List
+import Data.Map qualified as Map
+import ExecHelpers
+import GHC.Records (HasField (..))
+import Label
 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.Process qualified as Proc
 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" )
+    <$> (label @"password" <$> fromPass "email/mailbox.org")
   where
-    fromPass name = Proc.readProcess "pass" [name] ""
-     <&> stringToText <&> textToBytesUtf8
-      <&> Char8.strip
+    fromPass name =
+      Proc.readProcess "pass" [name] ""
+        <&> stringToText
+        <&> textToBytesUtf8
+        <&> Char8.strip
+
+progName :: Text
+progName = "mailbox-org"
+
+log :: Error -> IO ()
+log err = do
+  putStderrLn (errorContext progName err & prettyError)
 
 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
+main = run (CurrentProgramName progName) =<< secret
+
+data MailfilterList = MailfilterList
+  { id_ :: Json.Value,
+    rulename :: Text
+  }
+  deriving stock (Show, Eq)
+
+run ::
+  ( HasField "email" dat ByteString,
+    HasField "password" dat ByteString
+  ) =>
+  CurrentProgramName ->
+  dat ->
+  IO ()
+run currentProg loginData = do
+  session <- login loginData
+  filters <-
+    mailfilter
+      session
+      "list"
+      ( 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 @"id_" dat.parsed)
+      )
+      ([] :: [()])
+  filters
+    & Map.elems
+    & traverse_
+      ( updateIfDifferent
+          session
+          ( \el ->
+              pure $
+                el.original.mailfilter
+                  & KeyMap.insert "active" (Json.Bool False)
+          )
+          (pure ())
+      )
+  where
+    mapFromListOn :: Ord k => (a -> k) -> [a] -> Map k a
+    mapFromListOn on xs = xs <&> (\x -> (on x, x)) & Map.fromList
+    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" parser new
+        else do
+          log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
+
+    prettyRequestShort :: Client.Request -> Text
+    prettyRequestShort req = [fmt|request {req & Client.method}: {req & Client.host}{req & Client.path}{req & Client.queryString}|]
+
+    -- https://oxpedia.org/wiki/index.php?title=HTTP_API_MailFilter
+    mailfilter session action parser body = do
+      req <-
+        Client.parseRequest "https://office.mailbox.org/appsuite/api/mailfilter/v2"
+          <&> Client.setQueryString
+            [ ("action", Just action),
+              ("colums", Just "1")
+            ]
+          <&> Client.setRequestMethod "PUT"
+          <&> Client.setRequestBodyJSON body
+          <&> addSession session
+      req
+        & httpJSON currentProg [fmt|Cannot parse result for {req & prettyRequestShort}|] parser
+        >>= okOrDie
+        >>= (\resp -> printPretty resp >> pure resp)
+        <&> Client.responseBody
 
 newtype Session = Session Client.CookieJar
 
+httpJSON ::
+  CurrentProgramName ->
+  Error ->
+  Json.Parse Error b ->
+  Client.Request ->
+  IO (Client.Response b)
+httpJSON currentProg 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 currentProg "Server returned above inline error"
+            _ -> pure ()
+          val & Json.parseValue parser & \case
+            Left errs ->
+              errs
+                & parseErrorTree errMsg
+                & prettyErrorTree
+                & diePanic currentProg
+            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 =
@@ -60,16 +191,12 @@ addSession (Session jar) req = do
           & annotate "The cookie jar did not contain an open-exchange-session-*"
           & unwrapError
           & (.cookie_value)
-  (req
-    & Client.addToRequestQueryString [("session", Just sessionId)])
-      { Client.cookieJar = Just jar }
+
+  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 :: (HasField "email" dat ByteString, HasField "password" dat ByteString) => dat -> IO Session
 login dat = do
   rnd <- randomString
   req <-
@@ -91,7 +218,6 @@ login dat = do
     <&> Client.responseCookieJar
     <&> Session
   where
-
     -- For some reason they want the client to pass a random string
     -- which is used for the session?‽!?
     randomString = do
@@ -102,11 +228,10 @@ login dat = do
         & 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"
+  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
index b9b0c0f5f41d..bb8082bd4c80 100644
--- a/users/Profpatsch/mailbox-org/default.nix
+++ b/users/Profpatsch/mailbox-org/default.nix
@@ -5,8 +5,10 @@ let
     {
       libraries = [
         depot.users.Profpatsch.my-prelude
+        depot.users.Profpatsch.execline.exec-helpers-hs
         pkgs.haskellPackages.aeson
         pkgs.haskellPackages.http-conduit
+        pkgs.haskellPackages.aeson-better-errors
 
       ];
       ghcArgs = [ "-threaded" ];
diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal
index eab66242d4db..3a1ed917303d 100644
--- a/users/Profpatsch/mailbox-org/mailbox-org.cabal
+++ b/users/Profpatsch/mailbox-org/mailbox-org.cabal
@@ -10,11 +10,14 @@ executable mailbox-org
     build-depends:
         base >=4.15 && <5,
         my-prelude,
+        exec-helpers,
         random,
         http-conduit,
         http-client,
         aeson,
+        aeson-better-errors,
         bytestring,
-        process
+        process,
+        containers,
 
     default-language: Haskell2010