diff options
Diffstat (limited to 'users')
| -rw-r--r-- | users/Profpatsch/mailbox-org/MailboxOrg.hs | 171 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Label.hs | 15 |
2 files changed, 139 insertions, 47 deletions
diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs index 80222dbb0dc1..62277f192aef 100644 --- a/users/Profpatsch/mailbox-org/MailboxOrg.hs +++ b/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,57 +45,96 @@ 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 - -data MailfilterList = MailfilterList - { id_ :: Json.Value, - rulename :: Text - } - deriving stock (Show, Eq) +main = + secret + >>= run applyFilters run :: ( HasField "email" dat ByteString, HasField "password" dat ByteString ) => - CurrentProgramName -> + (Session -> IO ()) -> dat -> IO () -run currentProg loginData = do +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, + rulename :: Text + } + deriving stock (Show, Eq) + +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 ) diff --git a/users/Profpatsch/my-prelude/Label.hs b/users/Profpatsch/my-prelude/Label.hs index 0e339758ddbd..01b49353b987 100644 --- a/users/Profpatsch/my-prelude/Label.hs +++ b/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 |