feat(users/Profpatsch/mailbox-org): prepare adjusting filter config

In the end, it should be possible to write a single config which is
pushed to the service to steer which emails arrive.

This implements some helper functions and some more endpoints.

We implement Semigroup/Monoid for labelled tuples.

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

users/Profpatsch/mailbox-org/MailboxOrg.hs

@@ -19,7 +19,7 @@ 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 Data.Map.Strict qualified as Map
 import ExecHelpers
 import GHC.Records (HasField (..))
 import Label
@@ -45,15 +45,56 @@ secret = do
         <&> textToBytesUtf8
         <&> Char8.strip
 
-progName :: Text
+progName :: CurrentProgramName
 progName = "mailbox-org"
 
 log :: Error -> IO ()
 log err = do
-  putStderrLn (errorContext progName err & prettyError)
+  putStderrLn (errorContext progName.unCurrentProgramName err & prettyError)
 
 main :: IO ()
-main = run (CurrentProgramName progName) =<< secret
+main =
+  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,
+    HasField "rulename" 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 MailfilterList = MailfilterList
   { id_ :: Json.Value,
@@ -61,41 +102,39 @@ data MailfilterList = MailfilterList
   }
   deriving stock (Show, Eq)
 
-run ::
-  ( HasField "email" dat ByteString,
-    HasField "password" dat ByteString
-  ) =>
-  CurrentProgramName ->
-  dat ->
-  IO ()
-run currentProg loginData = do
-  session <- login loginData
+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 @"id_" dat.parsed)
+            <&> mapFromListOn (\dat -> getLabel @"rulename" dat.parsed)
       )
       ([] :: [()])
-  filters
-    & Map.elems
-    & traverse_
-      ( updateIfDifferent
-          session
-          ( \el ->
-              pure $
-                el.original.mailfilter
-                  & KeyMap.insert "active" (Json.Bool False)
-          )
-          (pure ())
-      )
+  let goal = Map.fromList [(label @"rulename" "another", 32), (label @"rulename" "xyz", 23)]
+  let actions = declarativeUpdate goal filters
+  log [fmt|Would * 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 ())
+    --     )
+
     mapFromListOn :: Ord k => (a -> k) -> [a] -> Map k a
     mapFromListOn on xs = xs <&> (\x -> (on x, x)) & Map.fromList
     updateIfDifferent ::
@@ -113,39 +152,79 @@ run currentProg loginData = do
       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
+          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.|]
 
-    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
+-- | 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),
+        ( [ ("action", Just action),
             ("colums", Just "1")
           ]
-          <&> Client.setRequestMethod "PUT"
+            <> opts.extraQueryParams
+        )
+      <&> Client.setRequestMethod (opts.httpMethod & fromMaybe "PUT")
       <&> Client.setRequestBodyJSON body
       <&> addSession session
   req
-        & httpJSON currentProg [fmt|Cannot parse result for {req & prettyRequestShort}|] parser
+    & httpJSON [fmt|Cannot parse result for {req & prettyRequestShort}|] parser
     >>= okOrDie
-        >>= (\resp -> printPretty resp >> pure resp)
+    -- >>= (\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 ::
-  CurrentProgramName ->
   Error ->
   Json.Parse Error b ->
   Client.Request ->
   IO (Client.Response b)
-httpJSON currentProg errMsg parser req = do
+httpJSON errMsg parser req = do
   req
     & Client.httpJSON @_ @Json.Value
     >>= traverse
@@ -155,14 +234,14 @@ httpJSON currentProg errMsg parser req = do
               | "error" `KeyMap.member` obj
                   && "error_desc" `KeyMap.member` obj -> do
                   printPretty obj
-                  diePanic currentProg "Server returned above inline error"
+                  diePanic progName "Server returned above inline error"
             _ -> pure ()
           val & Json.parseValue parser & \case
             Left errs ->
               errs
                 & parseErrorTree errMsg
                 & prettyErrorTree
-                & diePanic currentProg
+                & diePanic progName
             Right a -> pure a
       )
 

users/Profpatsch/my-prelude/Label.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GHC2021 #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE RankNTypes #-}
@@ -28,7 +29,7 @@ import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 -- then use dot-syntax to get the inner value.
 newtype Label (label :: Symbol) value = Label value
   deriving stock (Eq, Ord)
-  deriving newtype (Typeable)
+  deriving newtype (Typeable, Semigroup, Monoid)
 
 instance (KnownSymbol label, Show value) => Show (Label label value) where
   showsPrec d (Label val) =
@@ -91,6 +92,12 @@ instance HasField l1 (T2 l1 t1 l2 t2) t1 where
 instance HasField l2 (T2 l1 t1 l2 t2) t2 where
   getField (T2 _ t2) = getField @l2 t2
 
+instance (Semigroup t1, Semigroup t2) => Semigroup (T2 l1 t1 l2 t2) where
+  T2 t1 t2 <> T2 t1' t2' = T2 (t1 <> t1') (t2 <> t2')
+
+instance (Monoid t1, Monoid t2) => Monoid (T2 l1 t1 l2 t2) where
+  mempty = T2 mempty mempty
+
 -- | A named 3-element tuple. Since the elements are named, you can access them with `.`. See 'T2' for an example.
 data T3 (l1 :: Symbol) t1 (l2 :: Symbol) t2 (l3 :: Symbol) t3 = T3 (Label l1 t1) (Label l2 t2) (Label l3 t3)
 
@@ -105,3 +112,9 @@ instance HasField l2 (T3 l1 t1 l2 t2 l3 t3) t2 where
 -- | Access the third field by label
 instance HasField l3 (T3 l1 t1 l2 t2 l3 t3) t3 where
   getField (T3 _ _ t3) = getField @l3 t3
+
+instance (Semigroup t1, Semigroup t2, Semigroup t3) => Semigroup (T3 l1 t1 l2 t2 l3 t3) where
+  T3 t1 t2 t3 <> T3 t1' t2' t3' = T3 (t1 <> t1') (t2 <> t2') (t3 <> t3')
+
+instance (Monoid t1, Monoid t2, Monoid t3) => Monoid (T3 l1 t1 l2 t2 l3 t3) where
+  mempty = T3 mempty mempty mempty