mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
This commit is contained in:
Profpatsch 2023-01-02 12:51:10 +01:00
parent 95c9c2ae8b
commit 30ec1adce8
2 changed files with 140 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

173
users/Profpatsch/mailbox-org/MailboxOrg.hs
View file

@ -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.|]
-- | 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),
("colums", Just "1")
]
<> opts.extraQueryParams
)
<&> Client.setRequestMethod (opts.httpMethod & fromMaybe "PUT")
<&> Client.setRequestBodyJSON body
<&> addSession session
req
& httpJSON [fmt|Cannot parse result for {req & prettyRequestShort}|] parser
>>= okOrDie
-- >>= (\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}|]
-- 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
-- | 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
)

15
users/Profpatsch/my-prelude/Label.hs
View file

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