Create error codes for confer

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

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"

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 ()
 

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)

src/Confer/Effect/Symlink.hs

@@ -6,24 +6,23 @@
   , runSymlinkPure
   , Symlink (..)
   , SymlinkError (..)
-  , formatSymlinkError
   ) where
 
 import Control.Exception
 import Control.Monad
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Display
 import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Error.Static (Error)
 import Effectful.Error.Static qualified as Error
 import Effectful.FileSystem
 import Effectful.FileSystem qualified as FileSystem
 import Effectful.State.Static.Local qualified as State
 import System.Directory qualified as Directory
 import System.Directory.Internal (FileType (..), OsPath)
 import System.Directory.Internal qualified as Directory
 import System.IO.Error
@@ -74,7 +73,7 @@
     sourceFilePath <- liftIO $ OsPath.decodeFS source
     sourcePath <- FileSystem.makeAbsolute sourceFilePath
     destinationPath <- liftIO $ OsPath.decodeFS destination
     case sourceType of
       File ->
         createFileLink sourcePath destinationPath
       Directory ->
@@ -84,7 +83,7 @@
     sourceType <- liftIO $ do
       metadata <- Directory.getFileMetadata linkOsPath
       pure $ Directory.fileTypeFromMetadata metadata
     case sourceType of
       File ->
         FileSystem.removeFile linkFilePath
       Directory ->
@@ -140,20 +139,3 @@
                     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)