diff options
| -rw-r--r-- | users/Profpatsch/mailbox-org/MailboxOrg.hs | 201 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/default.nix | 2 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/mailbox-org.cabal | 5 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Aeson.hs | 188 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Data/Error/Tree.hs | 113 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 8 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 7 |
7 files changed, 484 insertions, 40 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 diff --git a/users/Profpatsch/my-prelude/Aeson.hs b/users/Profpatsch/my-prelude/Aeson.hs new file mode 100644 index 000000000000..ad095e1b43a7 --- /dev/null +++ b/users/Profpatsch/my-prelude/Aeson.hs @@ -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 don’t 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 don’t 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 diff --git a/users/Profpatsch/my-prelude/Data/Error/Tree.hs b/users/Profpatsch/my-prelude/Data/Error/Tree.hs new file mode 100644 index 000000000000..e8e45e704882 --- /dev/null +++ b/users/Profpatsch/my-prelude/Data/Error/Tree.hs @@ -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 diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 87731394fc47..8ff36a93d4e4 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -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; diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 48e71bb926a3..8ee3271d10fa 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -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 |