Layoutz

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,7 +33,7 @@ import Confer.Effect.Symlink
 
 data Options = Options
   { dryRun :: Bool
-  , verbose :: Bool
+  , quiet :: Bool
   , configurationFile :: Maybe OsPath
   , mDeploymentArch :: Maybe DeploymentArchitecture
   , mDeploymentOs :: Maybe DeploymentOS
@@ -62,6 +64,8 @@ main = do
     runOptions parseResult
       & runFileSystem
       & runErrorNoCallStack
+      & runConsole
+      & runConcurrent
       & runEff
   case result of
     Right _ -> pure ()
@@ -81,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
@@ -108,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 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 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

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,

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,

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.

src/Confer/CLI/Cmd/Check.hs

@@ -8,34 +8,42 @@ 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 _ ->
+      unless quiet $ printProgress "Checking links" 1.0
 
 validateSymlink
   :: Symlink :> es

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,22 +30,27 @@ deploy
   :: ( FileSystem :> es
      , Symlink :> es
      , IOE :> es
+     , Error CLIError :> es
      )
   => 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
-      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 <> " already exists."
+          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
-          when verbose $ do
+          Symlink.createSymlink fact.source fact.destination
+          unless quiet $ do
             liftIO $
               Text.putStrLn $
                 "[🔗] " <> display fact

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

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