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:
parent
545f9384b5
commit
1b003db725
7 changed files with 482 additions and 38 deletions
|
@ -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"
|
||||
|
|
|
@ -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" ];
|
||||
|
|
|
@ -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
|
||||
|
|
188
users/Profpatsch/my-prelude/Aeson.hs
Normal file
188
users/Profpatsch/my-prelude/Aeson.hs
Normal 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 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
|
113
users/Profpatsch/my-prelude/Data/Error/Tree.hs
Normal file
113
users/Profpatsch/my-prelude/Data/Error/Tree.hs
Normal 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
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue