about summary refs log tree commit diff
path: root/users/Profpatsch/mailbox-org
diff options
context:
space:
mode:
Diffstat (limited to 'users/Profpatsch/mailbox-org')
-rw-r--r--users/Profpatsch/mailbox-org/MailboxOrg.hs201
-rw-r--r--users/Profpatsch/mailbox-org/default.nix2
-rw-r--r--users/Profpatsch/mailbox-org/mailbox-org.cabal5
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