From 4d831f6aa2e4677aca1c04e9720f07fb6c1cce57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Sat, 29 Jun 2024 21:38:02 +0200 Subject: [PATCH] Create error codes for confer --- cabal.project | 11 ++++++-- confer.cabal | 4 ++- src/Confer/CLI/Cmd/Check.hs | 5 +--- src/Confer/CLI/Errors.hs | 53 +++++++++++++++++++++++++++++++----- src/Confer/Effect/Symlink.hs | 18 ------------ 5 files changed, 58 insertions(+), 33 deletions(-) diff --git a/cabal.project b/cabal.project index 21e8ee2..dd0145e 100644 --- a/cabal.project +++ b/cabal.project @@ -10,11 +10,16 @@ documentation: True tests: True --- package confer --- ghc-options: -fhpc +profiling: True + +library-profiling: True + +semaphore: True + +jobs: $ncpus package * - ghc-options: +RTS -A32m -RTS -j -haddock + ghc-options: +RTS -A32m -RTS -haddock allow-newer: hslua-aeson:unordered-containers diff --git a/confer.cabal b/confer.cabal index 4706d1c..3045636 100644 --- a/confer.cabal +++ b/confer.cabal @@ -50,7 +50,9 @@ common ghc-options -Wno-unticked-promoted-constructors if flag(development) - ghc-options: -finfo-table-map -Wno-unused-imports -Wno-unused-packages + ghc-options: + -finfo-table-map -Wno-unused-imports -Wno-unused-packages -prof + -fprof-auto -with-rtsopts=-p common rts-options ghc-options: -rtsopts -threaded "-with-rtsopts=-N -T" diff --git a/src/Confer/CLI/Cmd/Check.hs b/src/Confer/CLI/Cmd/Check.hs index 9bb4de4..1cd018f 100644 --- a/src/Confer/CLI/Cmd/Check.hs +++ b/src/Confer/CLI/Cmd/Check.hs @@ -24,10 +24,10 @@ import System.OsPath qualified as OsPath import Validation import Confer.CLI.Errors (CLIError (..)) +import Confer.CLI.Errors qualified as Errors import Confer.Config.Evaluator import Confer.Config.Types import Confer.Effect.Symlink (Symlink, SymlinkError (..)) -import Confer.Effect.Symlink qualified as Errors import Confer.Effect.Symlink qualified as Symlink check @@ -46,9 +46,6 @@ check deployments = do validateSymlink fact case result of Failure errors -> do - forM_ errors $ - \e -> - liftIO $ Text.putStrLn $ Errors.formatSymlinkError e Error.throwError (SymlinkErrors errors) Success _ -> pure () diff --git a/src/Confer/CLI/Errors.hs b/src/Confer/CLI/Errors.hs index 8bf14b1..3d786dc 100644 --- a/src/Confer/CLI/Errors.hs +++ b/src/Confer/CLI/Errors.hs @@ -14,6 +14,7 @@ import Confer.Effect.Symlink (SymlinkError (..)) import Confer.Effect.Symlink qualified as Symlink import Control.Monad.IO.Class (liftIO) import Data.Foldable +import Data.Word (Word8) data CLIError = NoDefaultConfigurationFile @@ -22,15 +23,35 @@ data CLIError | SymlinkErrors (NonEmpty SymlinkError) deriving stock (Eq, Show) +newtype ErrorCode = ErrorCode Word8 + deriving newtype (Eq, Show, Ord) + +instance Display ErrorCode where + displayBuilder (ErrorCode c) = "[CONFER-" <> displayBuilder c <> "]" + +cliErrorToCode :: CLIError -> ErrorCode +cliErrorToCode = \case + NoDefaultConfigurationFile -> ErrorCode 156 + NoUserProvidedConfigurationFile{} -> ErrorCode 169 + NoDeploymentsAvailable{} -> ErrorCode 123 + SymlinkErrors{} -> ErrorCode 192 + +symlinkErrorToCode :: SymlinkError -> ErrorCode +symlinkErrorToCode = \case + DoesNotExist{} -> ErrorCode 234 + IsNotSymlink{} -> ErrorCode 142 + WrongTarget{} -> ErrorCode 102 + reportError :: CLIError -> IO () reportError NoDefaultConfigurationFile = - System.die "[!] Could not find configuration file at ./deployments.lua" -reportError (NoUserProvidedConfigurationFile osPath) = do + System.die $ Text.unpack $ display (cliErrorToCode NoDefaultConfigurationFile) <> " Could not find configuration file at ./deployments.lua" +reportError e@(NoUserProvidedConfigurationFile osPath) = do filePath <- OsPath.decodeFS osPath - System.die $ "[!] Could not find configuration file at" <> filePath -reportError (NoDeploymentsAvailable os arch hostname) = do + System.die $ Text.unpack $ display (cliErrorToCode e) <> " Could not find configuration file at" <> Text.pack filePath +reportError e@(NoDeploymentsAvailable os arch hostname) = do let message = - "[!] Could not find deployments to run on " + display (cliErrorToCode e) + <> " Could not find deployments to run on " <> display arch <> "-" <> display os @@ -39,6 +60,24 @@ reportError (NoDeploymentsAvailable os arch hostname) = do System.die $ Text.unpack message reportError (SymlinkErrors errors) = do forM_ errors $ - \e -> - liftIO $ Text.putStrLn $ Symlink.formatSymlinkError e + \err -> + liftIO $ Text.putStrLn $ formatSymlinkError err System.exitFailure + +formatSymlinkError :: SymlinkError -> Text +formatSymlinkError e@(DoesNotExist path) = + display (symlinkErrorToCode e) + <> " " + <> display (Text.pack . show $ path) + <> " does not exist" +formatSymlinkError e@(IsNotSymlink path) = + display (symlinkErrorToCode e) + <> display (Text.pack . show $ path) + <> " is not a symbolic link" +formatSymlinkError e@(WrongTarget linkPath expectedTarget actualTarget) = + display (symlinkErrorToCode e) + <> display (Text.pack . show $ linkPath) + <> " points to " + <> display (Text.pack . show $ actualTarget) + <> " instead of pointing to " + <> display (Text.pack . show $ expectedTarget) diff --git a/src/Confer/Effect/Symlink.hs b/src/Confer/Effect/Symlink.hs index a78dde5..8cb650b 100644 --- a/src/Confer/Effect/Symlink.hs +++ b/src/Confer/Effect/Symlink.hs @@ -6,7 +6,6 @@ module Confer.Effect.Symlink , runSymlinkPure , Symlink (..) , SymlinkError (..) - , formatSymlinkError ) where import Control.Exception @@ -140,20 +139,3 @@ runSymlinkPure virtualFS = reinterpret (State.evalState virtualFS) $ \_ -> \case actualLinkTarget ) Nothing -> pure $ Left (DoesNotExist linkPath) - -formatSymlinkError :: SymlinkError -> Text -formatSymlinkError (DoesNotExist path) = - "[!] " - <> display (Text.pack . show $ path) - <> " does not exist" -formatSymlinkError (IsNotSymlink path) = - "[!] " - <> display (Text.pack . show $ path) - <> " is not a symbolic link" -formatSymlinkError (WrongTarget linkPath expectedTarget actualTarget) = - "[!] " - <> display (Text.pack . show $ linkPath) - <> " points to " - <> display (Text.pack . show $ actualTarget) - <> " instead of pointing to " - <> display (Text.pack . show $ expectedTarget)