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

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>
This commit is contained in:
Profpatsch 2023-01-02 03:02:48 +01:00
parent 545f9384b5
commit 1b003db725
7 changed files with 482 additions and 38 deletions

View file

@ -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
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) =>
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
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"

View file

@ -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" ];

View file

@ -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

View file

@ -0,0 +1,188 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Aeson where
import Data.Aeson (Encoding, FromJSON (parseJSON), GFromJSON, GToEncoding, GToJSON, Options (fieldLabelModifier), ToJSON (toEncoding, toJSON), Value (..), Zero, defaultOptions, genericParseJSON, genericToEncoding, genericToJSON, withObject)
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.Encoding qualified as Enc
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Char qualified
import Data.Error.Tree
import Data.Foldable qualified as Foldable
import Data.Int (Int64)
import Data.List (isPrefixOf)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)
import Data.String (IsString (fromString))
import Data.Text.Lazy qualified as Lazy
import Data.Vector qualified as Vector
import GHC.Generics (Generic (Rep))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Label
import MyPrelude
import Test.Hspec (describe, it, shouldBe)
import Test.Hspec qualified as Hspec
-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree'
parseErrorTree :: Error -> Json.ParseError Error -> ErrorTree
parseErrorTree contextMsg errs =
errs
& Json.displayError prettyError
<&> newError
& nonEmpty
& \case
Nothing -> singleError contextMsg
Just errs' -> errorTree contextMsg errs'
-- | Parse a key from the object, à la 'Json.key', return a labelled value.
--
-- We dont provide a version that infers the json object key,
-- since that conflates internal naming with the external API, which is dangerous.
--
-- @@
-- do
-- txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" Text)
-- @@
keyLabel ::
forall label err m a.
Monad m =>
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label a)
keyLabel = do
keyLabel' (Proxy @label)
-- | Parse a key from the object, à la 'Json.key', return a labelled value.
-- Version of 'keyLabel' that requires a proxy.
--
-- @@
-- do
-- txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" Text)
-- @@
keyLabel' ::
forall label err m a.
Monad m =>
Proxy label ->
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label a)
keyLabel' Proxy key parser = label @label <$> Json.key key parser
-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
--
-- We dont provide a version that infers the json object key,
-- since that conflates internal naming with the external API, which is dangerous.
--
-- @@
-- do
-- txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" (Maybe Text))
-- @@
keyLabelMay ::
forall label err m a.
Monad m =>
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label (Maybe a))
keyLabelMay = do
keyLabelMay' (Proxy @label)
-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
-- Version of 'keyLabelMay' that requires a proxy.
--
-- @@
-- do
-- txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" (Maybe Text))
-- @@
keyLabelMay' ::
forall label err m a.
Monad m =>
Proxy label ->
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label (Maybe a))
keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser
-- | Like 'Json.key', but allows a list of keys that are tried in order.
--
-- This is intended for renaming keys in an object.
-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
--
-- If a key (new or old) exists, the inner parser will always be executed for that key.
keyRenamed :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a
keyRenamed (newKey :| oldKeys) inner =
keyRenamedTryOldKeys oldKeys inner >>= \case
Nothing -> Json.key newKey inner
Just parse -> parse
-- | Like 'Json.keyMay', but allows a list of keys that are tried in order.
--
-- This is intended for renaming keys in an object.
-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
--
-- If a key (new or old) exists, the inner parser will always be executed for that key.
keyRenamedMay :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a)
keyRenamedMay (newKey :| oldKeys) inner =
keyRenamedTryOldKeys oldKeys inner >>= \case
Nothing -> Json.keyMay newKey inner
Just parse -> Just <$> parse
-- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any.
keyRenamedTryOldKeys :: Monad m => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a))
keyRenamedTryOldKeys oldKeys inner = do
oldKeys & traverse tryOld <&> catMaybes <&> nonEmpty <&> \case
Nothing -> Nothing
Just (old :| _moreOld) -> Just old
where
tryOld key =
Json.keyMay key (pure ()) <&> \case
Just () -> Just $ Json.key key inner
Nothing -> Nothing
test_keyRenamed :: Hspec.Spec
test_keyRenamed = do
describe "keyRenamed" $ do
let parser = keyRenamed ("new" :| ["old"]) Json.asText
let p = Json.parseValue @() parser
it "accepts the new key and the old key" $ do
p (Object (KeyMap.singleton "new" (String "text")))
`shouldBe` (Right "text")
p (Object (KeyMap.singleton "old" (String "text")))
`shouldBe` (Right "text")
it "fails with the old key in the error if the inner parser is wrong" $ do
p (Object (KeyMap.singleton "old" Null))
`shouldBe` (Left (Json.BadSchema [Json.ObjectKey "old"] (Json.WrongType Json.TyString Null)))
it "fails with the new key in the error if the inner parser is wrong" $ do
p (Object (KeyMap.singleton "new" Null))
`shouldBe` (Left (Json.BadSchema [Json.ObjectKey "new"] (Json.WrongType Json.TyString Null)))
it "fails if the key is missing" $ do
p (Object KeyMap.empty)
`shouldBe` (Left (Json.BadSchema [] (Json.KeyMissing "new")))
describe "keyRenamedMay" $ do
let parser = keyRenamedMay ("new" :| ["old"]) Json.asText
let p = Json.parseValue @() parser
it "accepts the new key and the old key" $ do
p (Object (KeyMap.singleton "new" (String "text")))
`shouldBe` (Right (Just "text"))
p (Object (KeyMap.singleton "old" (String "text")))
`shouldBe` (Right (Just "text"))
it "allows the old and new key to be missing" $ do
p (Object KeyMap.empty)
`shouldBe` (Right Nothing)
-- | Create a json array from a list of json values.
jsonArray :: [Value] -> Value
jsonArray xs = xs & Vector.fromList & Array

View file

@ -0,0 +1,113 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Data.Error.Tree where
import Data.String (IsString (..))
import Data.Tree qualified as Tree
import MyPrelude
-- | A tree of 'Error's, with a single root 'Error' and 0..n nested 'ErrorTree's.
--
-- @@
-- top error
-- |
-- |-- error 1
-- | |
-- | -- error 1.1
-- |
-- |-- error 2
-- @@
newtype ErrorTree = ErrorTree {unErrorTree :: (Tree.Tree Error)}
deriving stock (Show)
instance IsString ErrorTree where
fromString = singleError . fromString
-- deriving newtype (Ord) -- TODO: Add this instance with containers-0.6.5
-- | Turn a single 'Error' into an 'ErrorTree', a leaf.
singleError :: Error -> ErrorTree
singleError e = ErrorTree $ Tree.Node e []
-- | Take a list of errors & create a new 'ErrorTree' with the given 'Error' as the root.
errorTree :: Error -> NonEmpty Error -> ErrorTree
errorTree topLevelErr nestedErrs =
ErrorTree
( Tree.Node
topLevelErr
(nestedErrs <&> (\e -> Tree.Node e []) & toList)
)
-- | Attach more context to the root 'Error' of the 'ErrorTree', via 'errorContext'.
errorTreeContext :: Text -> ErrorTree -> ErrorTree
errorTreeContext context (ErrorTree tree) =
ErrorTree $
tree
{ Tree.rootLabel = tree.rootLabel & errorContext context
}
-- | Nest the given 'Error' around the ErrorTree
--
-- @@
-- top level error
-- |
-- -- nestedError
-- |
-- -- error 1
-- |
-- -- error 2
-- @@
nestedError ::
Error -> -- top level
ErrorTree -> -- nested
ErrorTree
nestedError topLevelErr nestedErr =
ErrorTree $
Tree.Node
{ Tree.rootLabel = topLevelErr,
Tree.subForest = [nestedErr.unErrorTree]
}
-- | Nest the given 'Error' around the list of 'ErrorTree's.
--
-- @@
-- top level error
-- |
-- |- nestedError1
-- | |
-- | -- error 1
-- | |
-- | -- error 2
-- |
-- |- nestedError 2
-- @@
nestedMultiError ::
Error -> -- top level
NonEmpty ErrorTree -> -- nested
ErrorTree
nestedMultiError topLevelErr nestedErrs =
ErrorTree $
Tree.Node
{ Tree.rootLabel = topLevelErr,
Tree.subForest = nestedErrs & toList <&> (.unErrorTree)
}
prettyErrorTree :: ErrorTree -> Text
prettyErrorTree (ErrorTree tree) =
tree
<&> prettyError
<&> textToString
& Tree.drawTree
& stringToText
prettyErrorTrees :: NonEmpty ErrorTree -> Text
prettyErrorTrees forest =
forest
<&> (.unErrorTree)
<&> fmap prettyError
<&> fmap textToString
& toList
& Tree.drawForest
& stringToText

View file

@ -9,11 +9,15 @@ pkgs.haskellPackages.mkDerivation {
./MyPrelude.hs
./Label.hs
./Pretty.hs
./Data/Error/Tree.hs
./Aeson.hs
];
isLibrary = true;
libraryHaskellDepends = [
pkgs.haskellPackages.aeson
pkgs.haskellPackages.aeson-better-errors
pkgs.haskellPackages.PyF
pkgs.haskellPackages.errors
pkgs.haskellPackages.profunctors
@ -21,10 +25,12 @@ pkgs.haskellPackages.mkDerivation {
pkgs.haskellPackages.these
pkgs.haskellPackages.validation-selective
pkgs.haskellPackages.error
pkgs.haskellPackages.hspec
pkgs.haskellPackages.hspec-expectations-pretty-diff
pkgs.haskellPackages.hscolour
pkgs.haskellPackages.nicify-lib
pkgs.haskellPackages.ansi-terminal
pkgs.haskellPackages.vector
];
license = lib.licenses.mit;

View file

@ -9,6 +9,8 @@ library
MyPrelude
Label
Pretty
Data.Error.Tree
Aeson
-- Modules included in this executable, other than Main.
-- other-modules:
@ -17,6 +19,8 @@ library
-- other-extensions:
build-depends:
base >=4.15 && <5
, aeson
, aeson-better-errors
, PyF
, validation-selective
, these
@ -27,7 +31,10 @@ library
, error
, bytestring
, mtl
, hspec
, hspec-expectations-pretty-diff
, hscolour
, nicify-lib
, ansi-terminal
, vector
default-language: Haskell2010