Implement deployment

README.md

@@ -13,5 +13,7 @@ No binaries are currently available. See the Build instructions
 ## 🔧 Build
 
 *Confer* is made in Haskell. To build it from source, use [ghcup](https://www.haskell.org/ghcup/) to install the following toolchains:
-* `cabal` 3.10
+* `cabal` 3.12
+    `$ ghcup install cabal --force -u https://github.com/haskell/cabal/releases/download/cabal-head/cabal-head-Linux-x86_64.tar.gz head`
 * `ghc` 9.10.1
+    `$ ghcup tui` -> select GHC 9.10.1

app/Main.hs

@@ -1,12 +1,17 @@
+{-# LANGUAGE QuasiQuotes #-}
 module Main where
 
-import Effectful
 import Data.Function ((&))
+import Data.Map.Strict qualified as Map
+import Effectful
 import Effectful.FileSystem
 import Options.Applicative
+import System.OsPath
 
+import Confer.Cmd.Check qualified as Cmd
+import Confer.Cmd.Deploy qualified as Cmd
+import Confer.Config.Evaluator
 import Confer.Effect.Symlink 
-import Confer.Cmd.Check (check)
 
 data Options = Options
   { cliCommand :: Command
@@ -15,12 +20,19 @@ data Options = Options
 
 data Command
   = Check
+  | Deploy DeployOptions
+  deriving stock (Show, Eq)
+
+data DeployOptions = DeployOptions
+  { dryRun :: Bool
+  }
   deriving stock (Show, Eq)
 
 main :: IO ()
 main = do
   parseResult <- execParser (parseOptions `withInfo` "confer – The dotfiles manager")
   runOptions parseResult
+    & runFileSystem
     & runEff
 
 parseOptions :: Parser Options
@@ -31,19 +43,37 @@ parseCommand :: Parser Command
 parseCommand =
   subparser $
     command "check" (parseCheck `withInfo` "Ensure that the configured link destinations do not exist as files already")
+    <> command "deploy" (parseDeploy `withInfo` "Deploy the configured symbolic links")
 
 parseCheck :: Parser Command
 parseCheck = pure Check 
 
+parseDeploy :: Parser Command 
+parseDeploy =
+  Deploy <$>
+    ( DeployOptions 
+      <$> switch (long "dry-run" <> help "Do not perform actual file system operations")
+    )
+
 runOptions
   :: ( IOE :> es
+     , FileSystem :> es
      )
   => Options
   -> Eff es ()
-runOptions (Options Check) = 
-  check
+runOptions (Options Check) = do
+  deployments <- processConfiguration [osp|doc/confer_example.lua|]
+  Cmd.check deployments
     & runSymlinkIO 
-    & runFileSystem
+runOptions (Options (Deploy deployOptions)) = do
+  deployments <- processConfiguration [osp|doc/confer_example.lua|]
+  if deployOptions.dryRun
+  then
+    Cmd.deploy deployments
+      & runSymlinkPure Map.empty
+  else
+    Cmd.deploy deployments
+      & runSymlinkIO
 
 withInfo :: Parser a -> String -> ParserInfo a
 withInfo opts desc = info (helper <*> opts) $ progDesc desc

confer.cabal

@@ -2,11 +2,10 @@ cabal-version:   3.6
 name:            confer
 version:         0.1.0.0
 synopsis:        The dotfiles manager
-
 description:
   Confer is a configuration file manager that symlinks your configuration files into their appropriate locations.
   You can put your configuration files in version control and make them easily available to their applications.
-  
+
 license:         BSD-3-Clause
 license-file:    LICENSE
 author:          Théophile Choutri
@@ -15,19 +14,22 @@ copyright:       2024 Théophile Choutri
 build-type:      Simple
 extra-doc-files:
   CHANGELOG.md
-  README.md
   doc/*.md
+  README.md
 
-data-dir:
-  runtime/lua
-
+data-dir:        runtime/lua
 tested-with:     GHC ==9.10.1
 
 flag release
   description: Compile the project for release
   default:     False
   manual:      True
 
+flag development
+  description: Compile the project for development
+  default:     True
+  manual:      False
+
 common extensions
   default-extensions:
     DataKinds
@@ -50,15 +52,18 @@ common ghc-options
     -Wall -Wcompat -Widentities -Wincomplete-record-updates
     -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
     -fhide-source-paths -Wno-unused-do-bind -fshow-hole-constraints
-    -Wno-unticked-promoted-constructors -Werror=unused-imports
-    -fdicts-strict -fmax-worker-args=16 -fspec-constr-recursive=16
-    -funbox-strict-fields -Wno-unused-imports
+    -Wno-unticked-promoted-constructors
 
   if flag(release)
     ghc-options:
       -flate-specialise -funbox-strict-fields
       -finline-generics-aggressively -fexpose-all-unfoldings
-      -Werror=extended-warnings -Wunused-packages
+      -Werror=extended-warnings -fdicts-strict -fmax-worker-args=16
+      -fspec-constr-recursive=16 -funbox-strict-fields
+      -Wno-unused-packages -Werror=unused-imports
+
+  if flag(development)
+    ghc-options: -finfo-table-map -Wno-unused-imports -Wno-unused-packages
 
 common rts-options
   ghc-options: -rtsopts -threaded "-with-rtsopts=-N -T"
@@ -72,31 +77,33 @@ library
     Confer.API.Host
     Confer.API.User
     Confer.Cmd.Check
+    Confer.Cmd.Deploy
     Confer.Config.Evaluator
     Confer.Config.Types
     Confer.Effect.Symlink
 
   build-depends:
     , aeson
     , base
+    , containers
     , directory
     , effectful
     , effectful-core
     , filepath
     , hostname
     , hslua-aeson
     , hslua-core
-    , validation-selective
-    , selective
     , hslua-marshalling
     , hslua-module-system
     , hslua-packaging
     , placeholder
+    , selective
     , text
     , text-display
+    , validation-selective
     , vector
 
-  if !flag(release)
+  if flag(development)
     build-depends: placeholder
 
   hs-source-dirs:  src
@@ -109,11 +116,13 @@ executable confer
   build-depends:
     , base
     , confer
+    , filepath
+    , containers
     , effectful
     , effectful-core
     , optparse-applicative
 
-  if !flag(release)
+  if flag(development)
     build-depends: placeholder
 
   hs-source-dirs: app
@@ -132,3 +141,6 @@ test-suite confer-test
     , directory
     , effectful-core
     , filepath
+    , tasty
+    , tasty-hunit
+    , containers

src/Confer/Cmd/Check.hs

@@ -10,6 +10,8 @@ import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Display
 import Data.Text.IO qualified as Text
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
 import Effectful
 import Effectful.FileSystem (FileSystem)
 import Effectful.FileSystem qualified as FileSystem
@@ -26,28 +28,24 @@ import Confer.Effect.Symlink qualified as Symlink
 
 check
   :: ( IOE :> es
-     , FileSystem :> es
      , Symlink :> es
      )
-  => Eff es ()
-check = do
-  loadConfiguration >>= \case
-    Right allDeployments -> do
-        let currentOS = OS (Text.pack System.os)
-        let currentArch = Arch (Text.pack System.arch)
-        let deployments = adjustConfiguration currentOS currentArch allDeployments
-        result <- sequenceA . join <$> mapM (\deployment ->
-          forM deployment.facts $ \fact -> do
-            liftIO $ Text.putStrLn $ "[+] Checking " <> display fact
-            validateSymlink fact) deployments
-        case result of
-          Failure errors -> do
-            forM_ errors $
-              \e ->
-                liftIO $ Text.putStrLn $ formatSymlinkError e
-            liftIO System.exitFailure
-          Success _ -> pure ()
-    Left e -> error e
+  => Vector Deployment
+  -> Eff es ()
+check deployments = do
+  result <- mconcat . Vector.toList <$> do
+    let facts :: Vector Fact = foldMap (.facts) deployments
+    forM facts $ \fact -> do
+      liftIO $ Text.putStrLn $ "[+] Checking " <> display fact
+      validateSymlink fact
+  case result of
+    Failure errors -> do
+      forM_ errors $
+        \e ->
+          liftIO $ Text.putStrLn $ formatSymlinkError e
+      liftIO System.exitFailure
+    Success _ -> pure ()
+
 
 validateSymlink
   :: (Symlink :> es)
@@ -69,3 +67,10 @@ 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)

src/Confer/Cmd/Deploy.hs

@@ -0,0 +1,36 @@
+module Confer.Cmd.Deploy (deploy) where
+
+import Control.Placeholder
+import Data.Vector (Vector)
+import Effectful
+import Control.Monad
+import Effectful.FileSystem (FileSystem)
+import Effectful.FileSystem qualified as FileSystem
+import System.OsPath (OsPath, (</>))
+import System.OsPath qualified as OsPath
+
+import Confer.Effect.Symlink
+import Confer.Config.Types
+-- | Take a filtered and checked list of deployments.
+--
+-- For each fact, we perform sequentially:
+--   * Check that the desired file exists
+--   * Check that the target symlink does not exist
+--      * If it exists, make sure that it points to the 
+--        file that is version controlled
+--          * If it does not, raise an error
+deploy
+  :: ( FileSystem :> es
+     , Symlink :> es
+     , IOE :> es
+     )
+  => Vector Deployment
+  -> Eff es ()
+deploy deployments = do
+  forM_ deployments $ \d ->
+    forM_ d.facts $ \fact -> do
+      let osPath = fact.destination </> fact.source
+      filepath <- liftIO $ OsPath.decodeFS osPath
+      exists <- FileSystem.doesPathExist filepath
+      unless exists $
+        createSymlink fact.source fact.destination

src/Confer/Config/Evaluator.hs

@@ -1,6 +1,7 @@
 module Confer.Config.Evaluator
   ( loadConfiguration
   , adjustConfiguration
+  , processConfiguration
   ) where
 
 import Control.Monad (void)
@@ -18,6 +19,7 @@ import HsLua.Marshalling qualified as Lua
 import HsLua.Module.System qualified as Lua.System
 import HsLua.Packaging.Module qualified as Lua
 import System.IO (utf8, utf16le)
+import System.Info qualified as System
 import System.OsPath (OsPath)
 import System.OsPath qualified as OsPath
 import System.OsPath.Encoding qualified as OsPath
@@ -40,8 +42,9 @@ loadConfiguration
   :: ( IOE :> es
      , FileSystem :> es
      )
-  => Eff es (Either String (Vector Deployment))
-loadConfiguration = do
+  => OsPath
+  -> Eff es (Either String (Vector Deployment))
+loadConfiguration pathToConfigFile = do
   userModule <- API.mkUserModule
   hostModule <- API.mkHostModule
   liftIO $ Lua.run $ do
@@ -51,7 +54,8 @@ loadConfiguration = do
     Lua.registerModule Lua.System.documentedModule
     Lua.registerModule userModule
     Lua.registerModule hostModule
-    Lua.dofile (Just "./doc/confer_example.lua")
+    configFilePath <- liftIO $ OsPath.decodeFS pathToConfigFile
+    Lua.dofile (Just configFilePath)
       >>= \case {Lua.OK -> pure () ; _ -> Lua.throwErrorAsException}
     Lua.resultToEither <$> Lua.runPeeker peekConfig Lua.top
 
@@ -86,3 +90,21 @@ peekOsPath index = do
   case OsPath.encodeWith utf8 utf16le (Text.unpack result) of
     Right p -> pure p
     Left e -> fail $ OsPath.showEncodingException e
+
+processConfiguration 
+  :: ( IOE :> es
+     , FileSystem :> es
+     )
+  => OsPath
+  -> Eff es (Vector Deployment)
+processConfiguration pathToConfigFile = do
+  loadConfiguration pathToConfigFile >>= \case
+    Right allDeployments -> do
+      let currentOS = OS (Text.pack System.os)
+      let currentArch = Arch (Text.pack System.arch)
+      pure $ adjustConfiguration
+        currentOS
+        currentArch
+        allDeployments
+    Left e -> error e
+