From 72c518aac5b35019a60ffbc3398f824da9931389 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Wed, 22 Oct 2025 08:54:47 +0200 Subject: [PATCH 1/3] layoutz --- app/Main.hs | 6 ++++-- cabal.project.freeze | 2 ++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 1c7c793..24cbce1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,6 +36,7 @@ data Options = Options , mDeploymentArch :: Maybe DeploymentArchitecture , mDeploymentOs :: Maybe DeploymentOS , mDeploymentHostname :: Maybe Text + , pretty :: Bool , cliCommand :: Command } deriving stock (Show, Eq) @@ -90,6 +91,7 @@ parseOptions = (option deploymentOsOption (long "os" <> metavar "OS" <> help "Override the detected operating system ")) <*> optional (option str (long "hostname" <> metavar "HOSTNAME" <> help "Override the detected host name")) + <*> switch (long "pretty" <> help "Enable pretty output on the console") <*> parseCommand parseCommand :: Parser Command @@ -111,7 +113,7 @@ runOptions ) => Options -> Eff es () -runOptions (Options dryRun verbose configurationFile mArch mOs mHostname Check) = do +runOptions (Options dryRun verbose configurationFile mArch mOs mHostname isPretty Check) = do deploymentArch <- determineDeploymentArch verbose mArch deploymentOS <- determineDeploymentOS verbose mOs deployments <- @@ -133,7 +135,7 @@ runOptions (Options dryRun verbose configurationFile mArch mOs mHostname Check) case result of Left symlinkError -> Error.throwError (SymlinkErrors (NE.singleton symlinkError)) Right a -> pure a -runOptions (Options dryRun verbose configurationFile mArch mOs mHostname Deploy) = do +runOptions (Options dryRun verbose configurationFile mArch mOs mHostname isPretty Deploy) = do deploymentArch <- determineDeploymentArch verbose mArch deploymentOS <- determineDeploymentOS verbose mOs deployments <- processConfiguration verbose configurationFile deploymentArch deploymentOS mHostname diff --git a/cabal.project.freeze b/cabal.project.freeze index 71b720f..5bd4da4 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -14,6 +14,7 @@ constraints: any.OneTuple ==0.4.2, any.async ==2.2.5, async -bench, any.base ==4.20.2.0, + any.base-compat ==0.14.1, any.base-orphans ==0.9.3, any.bifunctors ==5.6.2, bifunctors +tagged, @@ -48,6 +49,7 @@ constraints: any.OneTuple ==0.4.2, any.ghc-boot-th ==9.10.3, any.ghc-internal ==9.1003.0, any.ghc-prim ==0.12.0, + any.gitrev ==1.3.1, any.hashable ==1.5.0.0, hashable -arch-native -random-initial-seed, any.hostname ==1.0, From 372c2e5be3c602b514f11cd121b0cbd4488f26a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri=20de=20Tarl=C3=A9?= Date: Mon, 24 Nov 2025 18:07:44 +0100 Subject: [PATCH 2/3] layoutz --- app/Main.hs | 37 +++++++++++++++++++-------------- confer.cabal | 2 ++ doc/MANUAL.md | 4 ++-- src/Confer/CLI/Cmd/Check.hs | 21 +++++++++++++------ src/Confer/CLI/Cmd/Deploy.hs | 6 +++--- src/Confer/CLI/UI.hs | 29 ++++++++++++++++++++++++++ src/Confer/Config/ConfigFile.hs | 28 ++++++++++++------------- src/Confer/Config/Evaluator.hs | 11 +++------- 8 files changed, 89 insertions(+), 49 deletions(-) create mode 100644 src/Confer/CLI/UI.hs diff --git a/app/Main.hs b/app/Main.hs index 24cbce1..e79f115 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,8 @@ import Data.Text qualified as Text import Data.Version (showVersion) import Development.GitRev import Effectful +import Effectful.Concurrent +import Effectful.Console.ByteString import Effectful.Error.Static import Effectful.Error.Static qualified as Error import Effectful.FileSystem @@ -31,12 +33,11 @@ import Confer.Effect.Symlink data Options = Options { dryRun :: Bool - , verbose :: Bool + , quiet :: Bool , configurationFile :: Maybe OsPath , mDeploymentArch :: Maybe DeploymentArchitecture , mDeploymentOs :: Maybe DeploymentOS , mDeploymentHostname :: Maybe Text - , pretty :: Bool , cliCommand :: Command } deriving stock (Show, Eq) @@ -63,6 +64,8 @@ main = do runOptions parseResult & runFileSystem & runErrorNoCallStack + & runConsole + & runConcurrent & runEff case result of Right _ -> pure () @@ -82,7 +85,7 @@ parseOptions = Options <$> switch (long "dry-run" <> help "Do not perform actual file system operations") - <*> switch (long "verbose" <> help "Make the program more talkative") + <*> switch (long "quiet" <> help "Make the program less talkative") <*> optional (option osPathOption (long "deployments-file" <> metavar "FILE" <> help "Use the specified deployments.lua file")) <*> optional @@ -91,7 +94,6 @@ parseOptions = (option deploymentOsOption (long "os" <> metavar "OS" <> help "Override the detected operating system ")) <*> optional (option str (long "hostname" <> metavar "HOSTNAME" <> help "Override the detected host name")) - <*> switch (long "pretty" <> help "Enable pretty output on the console") <*> parseCommand parseCommand :: Parser Command @@ -110,42 +112,45 @@ runOptions :: ( IOE :> es , Error CLIError :> es , FileSystem :> es + , Console :> es + , Concurrent :> es ) => Options -> Eff es () -runOptions (Options dryRun verbose configurationFile mArch mOs mHostname isPretty Check) = do - deploymentArch <- determineDeploymentArch verbose mArch - deploymentOS <- determineDeploymentOS verbose mOs +runOptions (Options dryRun quiet configurationFile mArch mOs mHostname Check) = do + deploymentArch <- determineDeploymentArch quiet mArch + deploymentOS <- determineDeploymentOS quiet mOs deployments <- processConfiguration - verbose + quiet configurationFile deploymentArch deploymentOS mHostname if dryRun then - Cmd.check verbose deployments + Cmd.check quiet deployments & runSymlinkPure Map.empty else do result <- - Cmd.check verbose deployments + Cmd.check quiet deployments & runSymlinkIO & runErrorNoCallStack + & runConsole case result of Left symlinkError -> Error.throwError (SymlinkErrors (NE.singleton symlinkError)) Right a -> pure a -runOptions (Options dryRun verbose configurationFile mArch mOs mHostname isPretty Deploy) = do - deploymentArch <- determineDeploymentArch verbose mArch - deploymentOS <- determineDeploymentOS verbose mOs - deployments <- processConfiguration verbose configurationFile deploymentArch deploymentOS mHostname +runOptions (Options dryRun quiet configurationFile mArch mOs mHostname Deploy) = do + deploymentArch <- determineDeploymentArch quiet mArch + deploymentOS <- determineDeploymentOS quiet mOs + deployments <- processConfiguration quiet configurationFile deploymentArch deploymentOS mHostname if dryRun then - Cmd.deploy verbose deployments + Cmd.deploy quiet deployments & runSymlinkPure Map.empty else do result <- - Cmd.deploy verbose deployments + Cmd.deploy quiet deployments & runSymlinkIO & runErrorNoCallStack case result of diff --git a/confer.cabal b/confer.cabal index 3a54f23..a6c38ee 100644 --- a/confer.cabal +++ b/confer.cabal @@ -85,6 +85,7 @@ library Confer.CLI.Cmd.Check Confer.CLI.Cmd.Deploy Confer.CLI.Errors + Confer.CLI.UI Confer.Config.ConfigFile Confer.Config.Evaluator Confer.Config.Types @@ -95,6 +96,7 @@ library build-depends: aeson, base, + bytestring, containers, directory, effectful, diff --git a/doc/MANUAL.md b/doc/MANUAL.md index 16850f6..3ad8c9f 100644 --- a/doc/MANUAL.md +++ b/doc/MANUAL.md @@ -27,8 +27,8 @@ Simulate the actions to be executed but doesn't do them. #### `--deployments-file` Use the specified deployments.lua file -#### `--verbose` -Make the execution more verbose about what it does. +#### `--quiet` +Make the execution less verbose about what it does. #### `--version` Display the version of the tool. diff --git a/src/Confer/CLI/Cmd/Check.hs b/src/Confer/CLI/Cmd/Check.hs index 8cecd42..4a02d58 100644 --- a/src/Confer/CLI/Cmd/Check.hs +++ b/src/Confer/CLI/Cmd/Check.hs @@ -8,34 +8,43 @@ import Data.Text.IO qualified as Text import Data.Vector (Vector) import Data.Vector qualified as Vector import Effectful +import Effectful.Concurrent +import Effectful.Console.ByteString import Effectful.Error.Static (Error) import Effectful.Error.Static qualified as Error +import GHC.Float import Validation import Confer.CLI.Errors (CLIError (..)) +import Confer.CLI.UI import Confer.Config.Types import Confer.Effect.Symlink (Symlink, SymlinkError (..)) import Confer.Effect.Symlink qualified as Symlink check - :: ( IOE :> es - , Symlink :> es + :: ( Symlink :> es , Error CLIError :> es + , Console :> es + , Concurrent :> es ) => Bool -> Vector Deployment -> Eff es () -check verbose deployments = do +check quiet deployments = do result <- mconcat . Vector.toList <$> do let facts :: Vector Fact = foldMap (.facts) deployments - forM facts $ \fact -> do - liftIO $ Text.putStrLn $ "Checking " <> display fact + Vector.iforM facts $ \index fact -> do + let percentage = (int2Double index / (int2Double $ Vector.length facts)) + threadDelay 30_000 + unless quiet $ printProgress "Checking links" percentage validateSymlink fact case result of Failure errors -> do Error.throwError (SymlinkErrors errors) - Success _ -> pure () + Success _ -> do + unless quiet $ printProgress "Checking links" 1.0 + pure () validateSymlink :: Symlink :> es diff --git a/src/Confer/CLI/Cmd/Deploy.hs b/src/Confer/CLI/Cmd/Deploy.hs index ddc8462..27189d5 100644 --- a/src/Confer/CLI/Cmd/Deploy.hs +++ b/src/Confer/CLI/Cmd/Deploy.hs @@ -30,7 +30,7 @@ deploy => Bool -> Vector Deployment -> Eff es () -deploy verbose deployments = do +deploy quiet deployments = do forM_ deployments $ \d -> forM_ d.facts $ \fact -> do filepath <- liftIO $ OsPath.decodeFS fact.destination @@ -38,10 +38,10 @@ deploy verbose deployments = do if destinationPathExists then do destination <- liftIO $ OsPath.decodeFS fact.destination - liftIO $ Text.putStrLn $ display destination <> " already exists." + liftIO $ Text.putStrLn $ display destination <> " ✅" else do createSymlink fact.source fact.destination - when verbose $ do + unless quiet $ do liftIO $ Text.putStrLn $ "[🔗] " <> display fact diff --git a/src/Confer/CLI/UI.hs b/src/Confer/CLI/UI.hs new file mode 100644 index 0000000..596a86e --- /dev/null +++ b/src/Confer/CLI/UI.hs @@ -0,0 +1,29 @@ +module Confer.CLI.UI where + +import Data.ByteString +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Effectful +import Effectful.Console.ByteString (Console) +import Effectful.Console.ByteString qualified as Console +import Layoutz + +printProgress + :: Console :> es + => String + -> Double + -> Eff es () +printProgress message percentage = do + let element = inlineBar message percentage + Console.putStr (overwriteNthLine 1 (T.encodeUtf8 $ T.pack $ render element)) + where + clearLine :: StrictByteString + clearLine = "\x1b[2K" + moveLineUp :: Int -> StrictByteString + moveLineUp n = "\x1b[" <> T.encodeUtf8 (T.pack (show n)) <> "A" + moveLineDown :: Int -> StrictByteString + moveLineDown n = "\x1b[" <> T.encodeUtf8 (T.pack (show n)) <> "B" + pos1 :: StrictByteString + pos1 = "\r" + overwriteNthLine :: Int -> StrictByteString -> StrictByteString + overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1 diff --git a/src/Confer/Config/ConfigFile.hs b/src/Confer/Config/ConfigFile.hs index 81760b7..83ef384 100644 --- a/src/Confer/Config/ConfigFile.hs +++ b/src/Confer/Config/ConfigFile.hs @@ -4,7 +4,7 @@ module Confer.Config.ConfigFile , determineDeploymentArch ) where -import Control.Monad (when) +import Control.Monad (unless, when) import Data.Text qualified as Text import Data.Text.Display @@ -36,7 +36,7 @@ processConfiguration , Error CLIError :> es ) => Bool - -- ^ Verbose + -- ^ Quiet -> Maybe OsPath -- ^ Potential configuration file path -> DeploymentArchitecture @@ -46,20 +46,20 @@ processConfiguration -> Maybe Text -- ^ hostname override -> Eff es (Vector Deployment) -processConfiguration verbose mConfigurationFilePath deploymentArch deploymentOS mHostname = do +processConfiguration quiet mConfigurationFilePath deploymentArch deploymentOS mHostname = do pathToConfigFile <- determineConfigurationFilePath mConfigurationFilePath - loadConfiguration verbose pathToConfigFile >>= \case + loadConfiguration quiet pathToConfigFile >>= \case Right allDeployments -> do currentHost <- case mHostname of Nothing -> do inferredHostname <- Text.pack <$> liftIO getHostName - when verbose $ + unless quiet $ liftIO $ Text.putStrLn $ "Hostname: " <> display inferredHostname <> " (detected)" pure inferredHostname Just overridenHostname -> do - when verbose $ + unless quiet $ liftIO $ Text.putStrLn $ "Hostname: " <> display overridenHostname <> " (overriden)" @@ -101,19 +101,19 @@ determineConfigurationFilePath mCLIConfigFilePath = determineDeploymentOS :: IOE :> es => Bool - -- ^ Verbose mode + -- ^ quiet mode -> Maybe DeploymentOS -- Potential override -> Eff es DeploymentOS -- Final result -determineDeploymentOS verbose = \case +determineDeploymentOS quiet = \case Nothing -> do let inferredOS = OS (Text.pack System.os) - when verbose $ do + unless quiet $ do liftIO $ Text.putStrLn $ "OS: " <> display inferredOS <> " (detected)" pure inferredOS Just overridenOS -> do - when verbose $ + unless quiet $ liftIO $ Text.putStrLn $ "OS: " <> display overridenOS <> " (overriden)" @@ -122,19 +122,19 @@ determineDeploymentOS verbose = \case determineDeploymentArch :: IOE :> es => Bool - -- ^ Verbose mode + -- ^ quiet mode -> Maybe DeploymentArchitecture -- Potential override -> Eff es DeploymentArchitecture -- Final result -determineDeploymentArch verbose = \case +determineDeploymentArch quiet = \case Nothing -> do let inferredArch = Arch (Text.pack System.arch) - when verbose $ do + unless quiet $ do liftIO $ Text.putStrLn $ "Architecture: " <> display inferredArch <> " (detected)" pure inferredArch Just overridenArch -> do - when verbose $ + unless quiet $ liftIO $ Text.putStrLn $ "Architecture: " <> display overridenArch <> " (overriden)" diff --git a/src/Confer/Config/Evaluator.hs b/src/Confer/Config/Evaluator.hs index 99b5b8d..93fbfe7 100644 --- a/src/Confer/Config/Evaluator.hs +++ b/src/Confer/Config/Evaluator.hs @@ -5,8 +5,7 @@ module Confer.Config.Evaluator , adjustConfiguration ) where -import Control.Monad (void, when) - +import Control.Monad (void, unless) import Data.Maybe (isNothing) import Data.Text (Text) import Data.Text qualified as Text @@ -58,23 +57,19 @@ loadConfiguration => Bool -> OsPath -> Eff es (Either String (Vector Deployment)) -loadConfiguration verbose pathToConfigFile = do +loadConfiguration quiet pathToConfigFile = do userModule <- API.mkUserModule hostModule <- API.mkHostModule liftIO $ Lua.run $ do Lua.openlibs -- load the default Lua packages let conferLua = $(embedFile "runtime/lua/confer.lua") - -- when verbose $ - -- liftIO $ - -- Text.putStrLn $ - -- "Loading " <> Text.pack conferLuaFilePath Lua.dostring conferLua Lua.setglobal "confer" Lua.registerModule Lua.System.documentedModule Lua.registerModule userModule Lua.registerModule hostModule configFilePath <- liftIO $ OsPath.decodeFS pathToConfigFile - when verbose $ + unless quiet $ liftIO $ Text.putStrLn $ "Loading " <> Text.pack configFilePath From 6a15d0369ae4488e9f161543d8ecfadd7cd5fdab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Fri, 26 Dec 2025 14:30:42 +0100 Subject: [PATCH 3/3] Perform check on pre-existing destination path if it already exists during deployment --- src/Confer/CLI/Cmd/Check.hs | 5 ++--- src/Confer/CLI/Cmd/Deploy.hs | 21 +++++++++++++++------ src/Confer/Config/Evaluator.hs | 2 +- 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/Confer/CLI/Cmd/Check.hs b/src/Confer/CLI/Cmd/Check.hs index 4a02d58..0d6bf4f 100644 --- a/src/Confer/CLI/Cmd/Check.hs +++ b/src/Confer/CLI/Cmd/Check.hs @@ -35,16 +35,15 @@ check quiet deployments = do mconcat . Vector.toList <$> do let facts :: Vector Fact = foldMap (.facts) deployments Vector.iforM facts $ \index fact -> do - let percentage = (int2Double index / (int2Double $ Vector.length facts)) + let percentage = int2Double index / int2Double (Vector.length facts) threadDelay 30_000 unless quiet $ printProgress "Checking links" percentage validateSymlink fact case result of Failure errors -> do Error.throwError (SymlinkErrors errors) - Success _ -> do + Success _ -> unless quiet $ printProgress "Checking links" 1.0 - pure () validateSymlink :: Symlink :> es diff --git a/src/Confer/CLI/Cmd/Deploy.hs b/src/Confer/CLI/Cmd/Deploy.hs index 27189d5..db15dea 100644 --- a/src/Confer/CLI/Cmd/Deploy.hs +++ b/src/Confer/CLI/Cmd/Deploy.hs @@ -2,17 +2,21 @@ module Confer.CLI.Cmd.Deploy (deploy) where import Control.Monad +import Data.List.NonEmpty qualified as NE import Data.Text.Display import Data.Text.IO qualified as Text import Data.Vector (Vector) import Effectful +import Effectful.Error.Static import Effectful.FileSystem (FileSystem) import Effectful.FileSystem qualified as FileSystem import System.OsPath (OsPath) import System.OsPath qualified as OsPath +import Confer.CLI.Errors import Confer.Config.Types -import Confer.Effect.Symlink +import Confer.Effect.Symlink (Symlink) +import Confer.Effect.Symlink qualified as Symlink -- | Take a filtered and checked list of deployments. -- @@ -26,6 +30,7 @@ deploy :: ( FileSystem :> es , Symlink :> es , IOE :> es + , Error CLIError :> es ) => Bool -> Vector Deployment @@ -33,14 +38,18 @@ deploy deploy quiet deployments = do forM_ deployments $ \d -> forM_ d.facts $ \fact -> do - filepath <- liftIO $ OsPath.decodeFS fact.destination - destinationPathExists <- FileSystem.doesPathExist filepath + linkFilepath <- liftIO $ OsPath.decodeFS fact.destination + destinationPathExists <- FileSystem.doesPathExist linkFilepath if destinationPathExists then do - destination <- liftIO $ OsPath.decodeFS fact.destination - liftIO $ Text.putStrLn $ display destination <> " ✅" + result <- Symlink.testSymlink fact.destination fact.source + case result of + Left err -> + throwError $ SymlinkErrors (NE.singleton err) + Right _ -> + liftIO $ Text.putStrLn $ display (linkFilepath <> " ✅") else do - createSymlink fact.source fact.destination + Symlink.createSymlink fact.source fact.destination unless quiet $ do liftIO $ Text.putStrLn $ diff --git a/src/Confer/Config/Evaluator.hs b/src/Confer/Config/Evaluator.hs index 93fbfe7..9e873b7 100644 --- a/src/Confer/Config/Evaluator.hs +++ b/src/Confer/Config/Evaluator.hs @@ -5,7 +5,7 @@ module Confer.Config.Evaluator , adjustConfiguration ) where -import Control.Monad (void, unless) +import Control.Monad (unless, void) import Data.Maybe (isNothing) import Data.Text (Text) import Data.Text qualified as Text