From 2ffc69dba6422b2d745fe04d5bd860b4b10f5da2 Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Tue, 19 Nov 2024 19:08:46 +1300 Subject: [PATCH] Update deps --- app/Main.hs | 14 +-- cabal.project | 35 +++--- flake.lock | 134 ++++++++++++++++----- flake.nix | 29 ++++- navi.cabal | 8 +- src/Navi.hs | 13 +- src/Navi/Args.hs | 1 - src/Navi/Config.hs | 4 +- src/Navi/Config/Toml.hs | 8 +- src/Navi/Config/Types.hs | 2 +- src/Navi/Effects/MonadSystemInfo.hs | 5 +- src/Navi/Event.hs | 6 +- src/Navi/NaviT.hs | 4 +- src/Navi/Prelude.hs | 31 +++-- test/integration/Integration/Exceptions.hs | 37 +++--- test/integration/Main.hs | 3 +- test/unit/Unit/Navi/Config.hs | 19 ++- test/unit/Unit/Navi/Config/Toml.hs | 1 - 18 files changed, 217 insertions(+), 137 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 455f955..5844e78 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,13 +10,9 @@ import Effects.FileSystem.HandleWriter (MonadHandleWriter (withBinaryFile), die) import Effects.FileSystem.PathReader qualified as Dir import Effects.FileSystem.PathWriter (MonadPathWriter) import Effects.FileSystem.PathWriter qualified as Dir -import Effects.FileSystem.Utils - ( encodeFpToOsThrowM, - encodeFpToValidOsThrowM, - osp, - ) import Effects.Time (MonadTime) import Effects.Time qualified as Time +import FileSystem.OsPath (encodeThrowM, encodeValidThrowM) import GHC.Conc.Sync (setUncaughtExceptionHandler) import Navi (runNavi, runNaviT) import Navi.Args (Args, getArgs) @@ -46,7 +42,7 @@ main = do args <- getArgs config <- tryParseConfig args - `catchAny` writeConfigErr + `catchSync` writeConfigErr withLogEnv (config ^. #logging) $ \logEnv -> do let mkNaviEnv :: (LogEnv -> Config -> IO env) -> IO env @@ -121,7 +117,7 @@ withLogHandle logging onMHandle = do handleLogSize xdgState sizeMode currTimeOs <- - encodeFpToValidOsThrowM + encodeValidThrowM . fmap replaceSpc =<< Time.getSystemTimeString let logFile = xdgState currTimeOs <> [osp|.log|] @@ -152,7 +148,7 @@ writeConfigErr ex = do let logFile = xdgBase [osp|config_fatal.log|] renameIfExists logFile writeFileUtf8 logFile $ "Couldn't read config: " <> pack (displayException ex) - throwCS ex + throwM ex renameIfExists :: ( HasCallStack, @@ -184,7 +180,7 @@ uniqName fp = go 1 go !counter | counter == maxBound = die $ "Failed renaming file: " <> show fp | otherwise = do - fp' <- (fp <>) <$> encodeFpToOsThrowM (show counter) + fp' <- (fp <>) <$> encodeThrowM (show counter) b <- Dir.doesFileExist fp' if b then go (counter + 1) diff --git a/cabal.project b/cabal.project index 0d9f6e1..dfefdb2 100644 --- a/cabal.project +++ b/cabal.project @@ -32,15 +32,24 @@ source-repository-package source-repository-package type: git location: https://github.com/tbidne/bounds.git - tag: f93b202c9d154b25b42b048570cf6648451aa577 + tag: fb05a7288020d2bca0dbe45cd43d2c030f5a238c + +source-repository-package + type: git + location: https://github.com/tbidne/exception-utils.git + tag: 9ecb81e4a16f62736dbe7f90cb1983e7212b0c0f + +source-repository-package + type: git + location: https://github.com/tbidne/fs-utils.git + tag: 3fc40b75e89af85f9babf315a977ab17dc331495 source-repository-package type: git location: https://github.com/tbidne/monad-effects.git - tag: f3496c0d2606540498d6fd503e6855441ca03ee1 + tag: 32ec7ad8b875360fda8230969c0ab5a30ede17aa subdir: lib/effects-env - lib/effects-exceptions lib/effects-async lib/effects-fs lib/effects-ioref @@ -56,7 +65,7 @@ source-repository-package source-repository-package type: git location: https://github.com/tbidne/pythia.git - tag: 9b29afe578ca58f57b4a8278db2175fbdc3588e8 + tag: 9ad009184281b0f206160d385cc4aceca6efa1bd source-repository-package type: git @@ -66,31 +75,19 @@ source-repository-package source-repository-package type: git location: https://github.com/tbidne/si-bytes.git - tag: 308faf0ab25b39e0dda8de23d5d315e82260080f + tag: 8132d4c7ab1109b2818832bae13eccff398f7aa3 source-repository-package type: git location: https://github.com/tbidne/smart-math.git - tag: 9bd570201445904d12d0e0b792f171d02e6f361e + tag: d07ba621a076416f2724bb8876a4d3ad7ed8a10e source-repository-package type: git location: https://github.com/tbidne/time-conv.git - tag: 0d1581593a484ac5717c0b5c3965f5ca54605cdb + tag: 971a560f3ccfd7d8ea974affa85492f91713359c allow-newer: aeson:th-abstraction allow-newer: dbus:template-haskell allow-newer: hedgehog:template-haskell allow-newer: tasty-hedgehog:base - ---allow-newer: dbus:template-haskell ---allow-newer: dbus:transformers ---allow-newer: dbus:unix ---allow-newer: these-skinny:base ---allow-newer: refined:aeson ---allow-newer: refined:base ---allow-newer: refined:bytestring ---allow-newer: refined:deepseq ---allow-newer: refined:mtl ---allow-newer: refined:template-haskell ---allow-newer: refined:text \ No newline at end of file diff --git a/flake.lock b/flake.lock index b459d90..449512b 100644 --- a/flake.lock +++ b/flake.lock @@ -39,11 +39,11 @@ ] }, "locked": { - "lastModified": 1716375824, - "narHash": "sha256-WG9ldBj1COftpPleldonF1f+dBJ5ojmlL84ZpTq9i1U=", + "lastModified": 1721861181, + "narHash": "sha256-PJJl3tH2/BER+MPMj0UwZa1PQLa3/E18k2V/qhZyyJY=", "owner": "tbidne", "repo": "bounds", - "rev": "f93b202c9d154b25b42b048570cf6648451aa577", + "rev": "fb05a7288020d2bca0dbe45cd43d2c030f5a238c", "type": "github" }, "original": { @@ -52,16 +52,42 @@ "type": "github" } }, + "exception-utils": { + "inputs": { + "flake-parts": [ + "flake-parts" + ], + "nix-hs-utils": [ + "nix-hs-utils" + ], + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1730335978, + "narHash": "sha256-kn8ip6G4CoB38P7vEzm71u126FOTlO1NCA5mMNpQ4AA=", + "owner": "tbidne", + "repo": "exception-utils", + "rev": "9ecb81e4a16f62736dbe7f90cb1983e7212b0c0f", + "type": "github" + }, + "original": { + "owner": "tbidne", + "repo": "exception-utils", + "type": "github" + } + }, "flake-parts": { "inputs": { "nixpkgs-lib": "nixpkgs-lib" }, "locked": { - "lastModified": 1715865404, - "narHash": "sha256-/GJvTdTpuDjNn84j82cU6bXztE0MSkdnTWClUCRub78=", + "lastModified": 1730504689, + "narHash": "sha256-hgmguH29K2fvs9szpq2r3pz2/8cJd2LPS+b4tfNFCwE=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "8dc45382d5206bd292f9c2768b8058a8fd8311d9", + "rev": "506278e768c2a08bec68eb62932193e341f55c90", "type": "github" }, "original": { @@ -70,6 +96,32 @@ "type": "github" } }, + "fs-utils": { + "inputs": { + "flake-parts": [ + "flake-parts" + ], + "nix-hs-utils": [ + "nix-hs-utils" + ], + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1731533795, + "narHash": "sha256-UnHSbqtumGI3FSowobEhELBWETqx70QlUEN0ie1SGoM=", + "owner": "tbidne", + "repo": "fs-utils", + "rev": "3fc40b75e89af85f9babf315a977ab17dc331495", + "type": "github" + }, + "original": { + "owner": "tbidne", + "repo": "fs-utils", + "type": "github" + } + }, "monad-effects": { "inputs": { "algebra-simple": [ @@ -78,9 +130,15 @@ "bounds": [ "bounds" ], + "exception-utils": [ + "exception-utils" + ], "flake-parts": [ "flake-parts" ], + "fs-utils": [ + "fs-utils" + ], "nix-hs-utils": [ "nix-hs-utils" ], @@ -92,11 +150,11 @@ ] }, "locked": { - "lastModified": 1716381616, - "narHash": "sha256-E78napESWd0l4fM63LmmqhYJanGFDULftOWfySYmjA4=", + "lastModified": 1731531099, + "narHash": "sha256-rQSOKFhczx9N3887XuBxvGLQXfzpR3MuJTmqvE8rxPQ=", "owner": "tbidne", "repo": "monad-effects", - "rev": "f3496c0d2606540498d6fd503e6855441ca03ee1", + "rev": "32ec7ad8b875360fda8230969c0ab5a30ede17aa", "type": "github" }, "original": { @@ -107,11 +165,11 @@ }, "nix-hs-utils": { "locked": { - "lastModified": 1713310032, - "narHash": "sha256-fKf7G+wwUoFF2ZfnINncmSgdAR0BlBitx+ENUjxgfcg=", + "lastModified": 1730953801, + "narHash": "sha256-RGRGB7HWoD7iNyTEqylkIlmK1TrPH+o8Afl2jZngj9Q=", "owner": "tbidne", "repo": "nix-hs-utils", - "rev": "a28bc9ae3797ad713deeac4f52df46cb391d7002", + "rev": "413e36cdd878ae5dee8b581bb1bca77feb4700c8", "type": "github" }, "original": { @@ -122,11 +180,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1716330097, - "narHash": "sha256-8BO3B7e3BiyIDsaKA0tY8O88rClYRTjvAp66y+VBUeU=", + "lastModified": 1731676054, + "narHash": "sha256-OZiZ3m8SCMfh3B6bfGC/Bm4x3qc1m2SVEAlkV6iY7Yg=", "owner": "nixos", "repo": "nixpkgs", - "rev": "5710852ba686cc1fd0d3b8e22b3117d43ba374c2", + "rev": "5e4fbfb6b3de1aa2872b76d49fafc942626e2add", "type": "github" }, "original": { @@ -138,14 +196,14 @@ }, "nixpkgs-lib": { "locked": { - "lastModified": 1714640452, - "narHash": "sha256-QBx10+k6JWz6u7VsohfSw8g8hjdBZEf8CFzXH1/1Z94=", + "lastModified": 1730504152, + "narHash": "sha256-lXvH/vOfb4aGYyvFmZK/HlsNsr/0CVWlwYvo2rxJk3s=", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/50eb7ecf4cd0a5756d7275c8ba36790e5bd53e33.tar.gz" + "url": "https://github.com/NixOS/nixpkgs/archive/cc2f28000298e1269cea6612cd06ec9979dd5d7f.tar.gz" }, "original": { "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/50eb7ecf4cd0a5756d7275c8ba36790e5bd53e33.tar.gz" + "url": "https://github.com/NixOS/nixpkgs/archive/cc2f28000298e1269cea6612cd06ec9979dd5d7f.tar.gz" } }, "pythia": { @@ -156,9 +214,15 @@ "bounds": [ "bounds" ], + "exception-utils": [ + "exception-utils" + ], "flake-parts": [ "flake-parts" ], + "fs-utils": [ + "fs-utils" + ], "monad-effects": [ "monad-effects" ], @@ -179,11 +243,11 @@ ] }, "locked": { - "lastModified": 1716382093, - "narHash": "sha256-w+BtGsqOGzWRROW1FaAatF0AiOpYnjweuBukCc4/4c4=", + "lastModified": 1731990772, + "narHash": "sha256-Rt7J0ltKe537D4nj0zUwhxjwz4KtUggfsvhl8D66J6g=", "owner": "tbidne", "repo": "pythia", - "rev": "9b29afe578ca58f57b4a8278db2175fbdc3588e8", + "rev": "9ad009184281b0f206160d385cc4aceca6efa1bd", "type": "github" }, "original": { @@ -228,7 +292,9 @@ "inputs": { "algebra-simple": "algebra-simple", "bounds": "bounds", + "exception-utils": "exception-utils", "flake-parts": "flake-parts", + "fs-utils": "fs-utils", "monad-effects": "monad-effects", "nix-hs-utils": "nix-hs-utils", "nixpkgs": "nixpkgs", @@ -258,11 +324,11 @@ ] }, "locked": { - "lastModified": 1716378077, - "narHash": "sha256-QYDjGCowOERXr/2JA+5hl4EpJxsU9ZKktEqowzPkWcs=", + "lastModified": 1731990143, + "narHash": "sha256-tfqAOvUM6Dkt5/aY1f+azvkBLrN9xF7j7V8ioS+IWYI=", "owner": "tbidne", "repo": "si-bytes", - "rev": "308faf0ab25b39e0dda8de23d5d315e82260080f", + "rev": "8132d4c7ab1109b2818832bae13eccff398f7aa3", "type": "github" }, "original": { @@ -290,11 +356,11 @@ ] }, "locked": { - "lastModified": 1716380345, - "narHash": "sha256-IfpHT70aAUy507iZGaAWR04K4Lf7efFw2SjD28Cbu0o=", + "lastModified": 1723092125, + "narHash": "sha256-rH/RX89JG6oNUz4qnCP1Yvip19z2sB+Ry1rmIIdpqT0=", "owner": "tbidne", "repo": "smart-math", - "rev": "9bd570201445904d12d0e0b792f171d02e6f361e", + "rev": "d07ba621a076416f2724bb8876a4d3ad7ed8a10e", "type": "github" }, "original": { @@ -311,9 +377,15 @@ "bounds": [ "bounds" ], + "exception-utils": [ + "exception-utils" + ], "flake-parts": [ "flake-parts" ], + "fs-utils": [ + "fs-utils" + ], "monad-effects": [ "monad-effects" ], @@ -325,11 +397,11 @@ ] }, "locked": { - "lastModified": 1716381820, - "narHash": "sha256-A6F4ipfubHX/Pey2GLpk+suqN3vaesig2J0tb4jpYJA=", + "lastModified": 1731989054, + "narHash": "sha256-GA2dl54T6FJknhpvNhwztxDkehkNWdamOSdT25LGYzg=", "owner": "tbidne", "repo": "time-conv", - "rev": "0d1581593a484ac5717c0b5c3965f5ca54605cdb", + "rev": "971a560f3ccfd7d8ea974affa85492f91713359c", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 2e098c3..cfcbf7f 100644 --- a/flake.nix +++ b/flake.nix @@ -6,7 +6,7 @@ nix-hs-utils.url = "github:tbidne/nix-hs-utils"; nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable"; - #haskell + # haskell algebra-simple = { url = "github:tbidne/algebra-simple"; inputs.flake-parts.follows = "flake-parts"; @@ -19,6 +19,18 @@ inputs.nix-hs-utils.follows = "nix-hs-utils"; inputs.nixpkgs.follows = "nixpkgs"; }; + exception-utils = { + url = "github:tbidne/exception-utils"; + inputs.flake-parts.follows = "flake-parts"; + inputs.nix-hs-utils.follows = "nix-hs-utils"; + inputs.nixpkgs.follows = "nixpkgs"; + }; + fs-utils = { + url = "github:tbidne/fs-utils"; + inputs.flake-parts.follows = "flake-parts"; + inputs.nix-hs-utils.follows = "nix-hs-utils"; + inputs.nixpkgs.follows = "nixpkgs"; + }; monad-effects = { url = "github:tbidne/monad-effects"; inputs.flake-parts.follows = "flake-parts"; @@ -27,6 +39,8 @@ inputs.algebra-simple.follows = "algebra-simple"; inputs.bounds.follows = "bounds"; + inputs.exception-utils.follows = "exception-utils"; + inputs.fs-utils.follows = "fs-utils"; inputs.smart-math.follows = "smart-math"; }; pythia = { @@ -37,8 +51,10 @@ inputs.algebra-simple.follows = "algebra-simple"; inputs.bounds.follows = "bounds"; - inputs.si-bytes.follows = "si-bytes"; + inputs.exception-utils.follows = "exception-utils"; + inputs.fs-utils.follows = "fs-utils"; inputs.monad-effects.follows = "monad-effects"; + inputs.si-bytes.follows = "si-bytes"; inputs.smart-math.follows = "smart-math"; inputs.time-conv.follows = "time-conv"; }; @@ -77,6 +93,8 @@ inputs.algebra-simple.follows = "algebra-simple"; inputs.bounds.follows = "bounds"; + inputs.exception-utils.follows = "exception-utils"; + inputs.fs-utils.follows = "fs-utils"; inputs.monad-effects.follows = "monad-effects"; }; }; @@ -93,7 +111,7 @@ perSystem = { pkgs, ... }: let - ghc-version = "ghc963"; + ghc-version = "ghc982"; compiler = pkgs.haskell.packages."${ghc-version}".override { overrides = final: prev: @@ -101,6 +119,8 @@ // nix-hs-utils.mkLibs inputs final [ "algebra-simple" "bounds" + "exception-utils" + "fs-utils" "pythia" "relative-time" "si-bytes" @@ -110,7 +130,6 @@ // nix-hs-utils.mkRelLibs "${monad-effects}/lib" final [ "effects-async" "effects-env" - "effects-exceptions" "effects-fs" "effects-ioref" "effects-logger-ns" @@ -142,7 +161,7 @@ apps = { format = nix-hs-utils.format compilerPkgs; lint = nix-hs-utils.lint compilerPkgs; - lintRefactor = nix-hs-utils.lintRefactor compilerPkgs; + lint-refactor = nix-hs-utils.lint-refactor compilerPkgs; }; }; systems = [ diff --git a/navi.cabal b/navi.cabal index 540522d..947678f 100644 --- a/navi.cabal +++ b/navi.cabal @@ -26,6 +26,7 @@ common common-exts default-extensions: ApplicativeDo DataKinds + DeriveAnyClass DerivingVia DuplicateRecordFields FunctionalDependencies @@ -85,7 +86,6 @@ library , dbus >=1.2.14 && <1.4 , deepseq >=1.4.6.0 && <1.6 , effects-async ^>=0.1 - , effects-exceptions ^>=0.1 , effects-fs ^>=0.1 , effects-ioref ^>=0.1 , effects-logger-ns ^>=0.1 @@ -94,6 +94,8 @@ library , effects-terminal ^>=0.1 , effects-thread ^>=0.1 , effects-time ^>=0.1 + , exception-utils ^>=0.1 + , exceptions ^>=0.10.4 , fdo-notify ^>=0.3.1 , monad-logger ^>=0.3.30 , mtl >=2.2.2 && <2.4 @@ -161,18 +163,18 @@ test-suite integration build-depends: , base , effects-async - , effects-exceptions , effects-fs , effects-logger-ns , effects-terminal , effects-thread , effects-time + , exception-utils , fdo-notify , navi , pythia , tasty , tasty-hunit , text - , time >=1.9.3 && <1.15 + , time >=1.9.3 && <1.15 hs-source-dirs: test/integration diff --git a/src/Navi.hs b/src/Navi.hs index fe90980..b15498c 100644 --- a/src/Navi.hs +++ b/src/Navi.hs @@ -11,6 +11,7 @@ module Navi ) where +import Control.Exception.Annotation.Utils (displayInner) import DBus.Client (ClientError (clientErrorFatal)) import DBus.Notify (UrgencyLevel (Critical, Normal)) import Data.Text qualified as T @@ -96,7 +97,7 @@ runNavi = do -- app. Async.link logThread runEvents evts - `catchAny` \e -> do + `catchSync` \e -> do Async.cancel logThread -- handle remaining logs queue <- asks getLogQueue @@ -119,7 +120,7 @@ runNavi = do {-# INLINEABLE runEvents #-} logExAndRethrow :: Text -> m a -> m a - logExAndRethrow prefix io = catchAny io $ \ex -> do + logExAndRethrow prefix io = catchSync io $ \ex -> do $(logError) (prefix <> pack (displayException ex)) throwM ex {-# INLINEABLE logExAndRethrow #-} @@ -148,8 +149,8 @@ processEvent (MkAnyEvent event) = addNamespace (fromString $ unpack name) $ do forever $ do $(logInfo) ("Checking " <> name) (Event.runEvent event >>= handleSuccess) - `catchCS` handleEventError - `catchAny` handleSomeException + `catch` handleEventError + `catchSync` handleSomeException sleep pi where name = event ^. #name @@ -211,7 +212,7 @@ exToNote :: SomeException -> NaviNote exToNote ex = MkNaviNote { summary = "Exception", - body = Just $ pack (displayException ex), + body = Just $ pack (displayInner ex), urgency = Just Critical, timeout = Nothing } @@ -232,7 +233,7 @@ pollNoteQueue = addNamespace "note-poller" $ do forever $ readTBQueueA queue >>= \nn -> - sendNote nn `catchCS` \ce -> + sendNote nn `catch` \ce -> -- NOTE: Rethrow all exceptions except: -- -- 1. Non-fatal dbus errors e.g. quickly sending the same notif twice. diff --git a/src/Navi/Args.hs b/src/Navi/Args.hs index 92bff78..dac75f4 100644 --- a/src/Navi/Args.hs +++ b/src/Navi/Args.hs @@ -16,7 +16,6 @@ import Data.Functor.Identity (Identity (Identity)) import Data.List qualified as L import Data.Version (Version (versionBranch)) import Effects.FileSystem.PathReader qualified as Dir -import Effects.FileSystem.Utils (osp) import Effects.Optparse (osPath) import Navi.Prelude import Options.Applicative (Parser, ParserInfo (ParserInfo)) diff --git a/src/Navi/Config.hs b/src/Navi/Config.hs index e371ee0..f8c21f4 100644 --- a/src/Navi/Config.hs +++ b/src/Navi/Config.hs @@ -48,7 +48,7 @@ readConfig = -- FIXME: Unused keys do not cause errors. This should probably be addressed -- upstream. See https://github.com/brandonchinn178/toml-reader/issues/12 case decode contents of - Left tomlErr -> throwCS $ TomlError tomlErr + Left tomlErr -> throwM $ TomlError tomlErr Right cfg -> tomlToConfig cfg tomlToConfig :: @@ -76,7 +76,7 @@ tomlToConfig toml = do allEvts = maybeEvts <> multipleEvts case allEvts of - [] -> throwCS NoEvents + [] -> throwM NoEvents (e : es) -> pure $ MkConfig diff --git a/src/Navi/Config/Toml.hs b/src/Navi/Config/Toml.hs index 7f59f26..a4923ef 100644 --- a/src/Navi/Config/Toml.hs +++ b/src/Navi/Config/Toml.hs @@ -12,7 +12,7 @@ import Data.Bytes (SomeSize) import Data.Bytes qualified as Bytes import Data.Char qualified as Ch import Data.Text qualified as T -import Effects.FileSystem.Utils (encodeFpToOsFail) +import FileSystem.OsPath (encodeFail) import GHC.Real (truncate) import Navi.Config.Types ( FilesSizeMode (FilesSizeModeDelete, FilesSizeModeWarn), @@ -83,7 +83,7 @@ locationDecoder = tomlDecoder >>= \case "default" -> pure DefPath "stdout" -> pure Stdout - f -> File <$> encodeFpToOsFail f + f -> File <$> encodeFail f noteSystemDecoder :: Decoder NoteSystem noteSystemDecoder = @@ -112,7 +112,7 @@ sizeModeDecoder = do -- NOTE: Try conversion to natural first for more precision. Fall back -- to double if that fails. case Bytes.parse @(SomeSize Natural) txt of - Right b -> Right $ Bytes.convert (Proxy @B) b + Right b -> Right $ Bytes.convert_ @_ @B b Left _ -> case Bytes.parse @(SomeSize Double) txt of - Right b -> Right (truncate <$> Bytes.convert (Proxy @B) b) + Right b -> Right (truncate <$> Bytes.convert_ @_ @B b) Left err -> Left err diff --git a/src/Navi/Config/Types.hs b/src/Navi/Config/Types.hs index 520a9dc..0122891 100644 --- a/src/Navi/Config/Types.hs +++ b/src/Navi/Config/Types.hs @@ -79,7 +79,7 @@ defaultLogging = -- | @since 0.1 defaultSizeMode :: FilesSizeMode -defaultSizeMode = FilesSizeModeDelete $ Bytes.convert Proxy fiftyMb +defaultSizeMode = FilesSizeModeDelete $ Bytes.convert_ fiftyMb where fiftyMb = MkBytes @M 50 diff --git a/src/Navi/Effects/MonadSystemInfo.hs b/src/Navi/Effects/MonadSystemInfo.hs index a4fcf46..85d5dd6 100644 --- a/src/Navi/Effects/MonadSystemInfo.hs +++ b/src/Navi/Effects/MonadSystemInfo.hs @@ -4,6 +4,7 @@ module Navi.Effects.MonadSystemInfo ) where +import Control.Exception.Annotation.Utils (displayInner) import Data.Text qualified as T import Navi.Event.Types (EventError (MkEventError, long, name, short)) import Navi.Prelude @@ -48,12 +49,12 @@ instance MonadSystemInfo IO where rethrowPythia :: Text -> IO a -> IO a rethrowPythia n io = - io `catchAny` \e -> + io `catchSync` \e -> throwM $ MkEventError { name = n, short = "PythiaException", - long = pack $ displayException e + long = pack $ displayInner e } instance (MonadSystemInfo m) => MonadSystemInfo (ReaderT e m) where diff --git a/src/Navi/Event.hs b/src/Navi/Event.hs index 07754f9..a17b6fd 100644 --- a/src/Navi/Event.hs +++ b/src/Navi/Event.hs @@ -83,9 +83,9 @@ blockRepeat repeatEvent newVal = addNamespace "blockRepeat" $ do then -- Already sent this alert, block. pure True else -- New alert, do not block. - do - writeIORef prevRef $ Just newVal - pure False + do + writeIORef prevRef $ Just newVal + pure False {-# INLINEABLE blockRepeat #-} -- | Determines if we should block the error event. The semantics are: diff --git a/src/Navi/NaviT.hs b/src/Navi/NaviT.hs index 13fa842..241cf23 100644 --- a/src/Navi/NaviT.hs +++ b/src/Navi/NaviT.hs @@ -85,7 +85,7 @@ instance MonadNotify (NaviT DBusEnv IO) where sendNote naviNote = addNamespace "dbus" $ do $(logDebug) (showt note) client <- asks getClient - liftIO $ addCS $ sendDbus client note + liftIO $ sendDbus client note where note = naviToDBus naviNote sendDbus c = void . DBusN.notify c @@ -95,7 +95,7 @@ instance MonadNotify (NaviT DBusEnv IO) where instance MonadNotify (NaviT NotifySendEnv IO) where sendNote naviNote = addNamespace "notify-send" $ do $(logDebug) noteTxt - liftIO $ addCS $ void $ Proc.readCreateProcess cp "notify-send" + liftIO $ void $ Proc.readCreateProcess cp "notify-send" where noteTxt = naviToNotifySend naviNote cp = Proc.shell $ unpack noteTxt diff --git a/src/Navi/Prelude.hs b/src/Navi/Prelude.hs index d144bce..2858de6 100644 --- a/src/Navi/Prelude.hs +++ b/src/Navi/Prelude.hs @@ -37,6 +37,7 @@ import Control.Applicative as X (<**>), ) import Control.DeepSeq as X (NFData) +import Control.Exception.Utils as X (catchSync) import Control.Monad as X ( Monad ((>>=)), forever, @@ -48,6 +49,19 @@ import Control.Monad as X (=<<), (>=>), ) +import Control.Monad.Catch as X + ( Exception (displayException), + MonadCatch, + MonadMask, + MonadThrow, + SomeException, + bracket, + catch, + finally, + mask, + throwM, + try, + ) import Control.Monad.Fail as X (MonadFail (fail)) import Control.Monad.IO.Class as X (MonadIO (liftIO)) import Control.Monad.Logger as X @@ -102,21 +116,6 @@ import Effects.Concurrent.STM as X writeTBQueueA, ) import Effects.Concurrent.Thread as X (MonadThread) -import Effects.Exception as X - ( Exception (displayException), - MonadCatch, - MonadMask, - MonadThrow, - SomeException, - addCS, - bracket, - catchAny, - catchCS, - finally, - mask, - throwCS, - throwM, - ) import Effects.FileSystem.FileReader as X ( MonadFileReader, readFileUtf8ThrowM, @@ -128,12 +127,12 @@ import Effects.FileSystem.HandleWriter as X MonadHandleWriter (hClose, hFlush, hPut, openBinaryFile), ) import Effects.FileSystem.PathReader as X (MonadPathReader) -import Effects.FileSystem.Utils as X (OsPath, ()) import Effects.IORef as X ( IORef, MonadIORef (modifyIORef', newIORef, readIORef, writeIORef), ) import Effects.System.Terminal as X (MonadTerminal, putStrLn, putTextLn) +import FileSystem.OsPath as X (OsPath, osp, ospPathSep, ()) import GHC.Enum as X (Bounded (maxBound, minBound)) import GHC.Err as X (error, undefined) import GHC.Float as X (Double) diff --git a/test/integration/Integration/Exceptions.hs b/test/integration/Integration/Exceptions.hs index ab7e53b..2b9a2be 100644 --- a/test/integration/Integration/Exceptions.hs +++ b/test/integration/Integration/Exceptions.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} @@ -7,13 +6,14 @@ -- | Tests fatal exceptions. module Integration.Exceptions (tests) where -import Control.Exception qualified as UnsafeEx +import Control.Exception.Annotation.Utils qualified as Ex +import Data.Text qualified as T import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import Data.Time.LocalTime (LocalTime (LocalTime), TimeOfDay (TimeOfDay), utc) import Effects.Concurrent.Async (ExceptionInLinkedThread (ExceptionInLinkedThread)) import Effects.Concurrent.Async qualified as Async import Effects.Concurrent.Thread (sleep) -import Effects.Exception qualified as Ex +import Effects.FileSystem.FileReader (decodeUtf8Lenient) import Effects.LoggerNS ( MonadLoggerNS (getNamespace, localNamespace), defaultLogFormatter, @@ -191,24 +191,23 @@ tests = badLoggerDies :: TestTree badLoggerDies = testCase "Logger exception kills Navi" $ do (ExceptionInLinkedThread _ ex, _) <- runExceptionApp LogThread - "MkTestE \"logger dying\"" @=? displayException ex - -{- ORMOLU_DISABLE -} + "MkTestE \"logger dying\"" @=? Ex.displayInner ex badNotifierDies :: TestTree badNotifierDies = testCase "Notify exception kills Navi" $ do -#if MIN_VERSION_base(4, 20, 0) - (ex, logs) <- runExceptionApp NotifyThread - "MkTestE \"notify dying\"" @=? Ex.displayInner @TestEx ex -#else - (Ex.MkExceptionCS ex _, logs) <- runExceptionApp NotifyThread - "MkTestE \"notify dying\"" @=? displayException @SomeException ex -#endif - assertBool (show logs) $ errLog `elem` logs - where - errLog = "[2022-02-08 10:20:05][int-ex-test][Error][src/Navi.hs:123:8] Notify: MkTestE \"notify dying\"\n" + (ex, logs) <- runExceptionApp @SomeException NotifyThread + "MkTestE \"notify dying\"" @=? Ex.displayInner ex -{- ORMOLU_ENABLE -} + -- search for log + foundLogRef <- newIORef False + for_ logs $ \l -> do + let t = decodeUtf8Lenient l + when (errLog `T.isPrefixOf` t) $ writeIORef foundLogRef True + + foundLog <- readIORef foundLogRef + unless foundLog (assertFailure $ "Did not find expectedLog: " <> show logs) + where + errLog = "[2022-02-08 10:20:05][int-ex-test][Error][src/Navi.hs:124:8] Notify: MkTestE \"notify dying\"" runExceptionApp :: forall e. @@ -250,9 +249,7 @@ runExceptionApp badThread = do -- NOTE: timeout after 10 seconds MkExceptionIO testRun = Async.race (sleep 10_000_000) (runNaviT runNavi env) - -- NOTE: The try that is in scope only works on sync exceptions, so we use - -- the one from base. - UnsafeEx.try @e testRun >>= \case + try @_ @e testRun >>= \case Left ex -> do logs <- readIORef logsRef pure (ex, logs) diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 51e1262..390d1ed 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -18,7 +18,6 @@ import Data.Text qualified as T import Effects.Concurrent.Async qualified as Async import Effects.FileSystem.PathReader qualified as Dir import Effects.FileSystem.PathWriter qualified as Dir -import Effects.FileSystem.Utils (osp) import Integration.Exceptions qualified as Exceptions import Integration.MockApp (MockEnv, configToMockEnv, runMockApp) import Integration.Prelude @@ -110,7 +109,7 @@ testSendExceptionDies :: TestTree testSendExceptionDies = testCase "Exception in send kills program" $ do result <- (runMock 3 sendExceptionConfig $> Nothing) - `catchCS` (pure . Just) + `catch` (pure . Just) expected @=? result where diff --git a/test/unit/Unit/Navi/Config.hs b/test/unit/Unit/Navi/Config.hs index fb5e153..267b712 100644 --- a/test/unit/Unit/Navi/Config.hs +++ b/test/unit/Unit/Navi/Config.hs @@ -1,25 +1,26 @@ +{-# LANGUAGE QuasiQuotes #-} + module Unit.Navi.Config ( tests, ) where -import Effects.FileSystem.Utils (unsafeEncodeFpToOs) +import FileSystem.OsPath (unsafeDecode) import Navi.Config qualified as Config import Navi.Config.Types ( Config, LogLoc (DefPath, Stdout), NoteSystem (DBus, NotifySend), ) -import System.IO (FilePath) import Unit.Prelude tests :: TestTree tests = testGroup "Navi.Config" - [ readsExample verifyConfig "examples/config.toml", - readsExample verifySimple "examples/simple.toml", - readsExample verifyMultiple "examples/multiple.toml" + [ readsExample verifyConfig [osp|examples/config.toml|], + readsExample verifySimple [osp|examples/simple.toml|], + readsExample verifyMultiple [osp|examples/multiple.toml|] ] where verifyConfig cfg = do @@ -40,10 +41,8 @@ tests = Just DefPath @=? cfg ^. #logging % #location 1 @=? length (cfg ^. #events) -readsExample :: (Config -> IO ()) -> FilePath -> TestTree -readsExample verifyCfg fp = - testCase ("Reads " <> fp) +readsExample :: (Config -> IO ()) -> OsPath -> TestTree +readsExample verifyCfg p = + testCase ("Reads " <> unsafeDecode p) $ Config.readConfig p >>= verifyCfg - where - p = unsafeEncodeFpToOs fp diff --git a/test/unit/Unit/Navi/Config/Toml.hs b/test/unit/Unit/Navi/Config/Toml.hs index 5558e73..8513468 100644 --- a/test/unit/Unit/Navi/Config/Toml.hs +++ b/test/unit/Unit/Navi/Config/Toml.hs @@ -7,7 +7,6 @@ where import DBus.Notify (UrgencyLevel (Critical)) import Data.Text qualified as T -import Effects.FileSystem.Utils (osp) import Navi.Config.Toml ( ConfigToml ( MkConfigToml,