Create error codes for confer

tchoutri · Jun 29, 2024 · 4d831f6 · 4d831f6
1 parent 9965a51
commit 4d831f6
Show file tree

Hide file tree

Showing 5 changed files with 58 additions and 33 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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)