diff --git a/README.md b/README.md index 3a31658..0591f0d 100644 --- a/README.md +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index 1f2f264..5dfa7dd 100644 --- a/app/Main.hs +++ b/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 diff --git a/confer.cabal b/confer.cabal index b0764c5..f7b44bd 100644 --- a/confer.cabal +++ b/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,12 +14,10 @@ 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 @@ -28,6 +25,11 @@ flag 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,6 +77,7 @@ library Confer.API.Host Confer.API.User Confer.Cmd.Check + Confer.Cmd.Deploy Confer.Config.Evaluator Confer.Config.Types Confer.Effect.Symlink @@ -79,6 +85,7 @@ library build-depends: , aeson , base + , containers , directory , effectful , effectful-core @@ -86,17 +93,17 @@ library , 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 diff --git a/src/Confer/Cmd/Check.hs b/src/Confer/Cmd/Check.hs index 9beac62..c7a97f3 100644 --- a/src/Confer/Cmd/Check.hs +++ b/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) diff --git a/src/Confer/Cmd/Deploy.hs b/src/Confer/Cmd/Deploy.hs new file mode 100644 index 0000000..198f15b --- /dev/null +++ b/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 diff --git a/src/Confer/Config/Evaluator.hs b/src/Confer/Config/Evaluator.hs index 27327d7..f6684ef 100644 --- a/src/Confer/Config/Evaluator.hs +++ b/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 + diff --git a/src/Confer/Effect/Symlink.hs b/src/Confer/Effect/Symlink.hs index 79c6967..303188e 100644 --- a/src/Confer/Effect/Symlink.hs +++ b/src/Confer/Effect/Symlink.hs @@ -3,6 +3,8 @@ module Confer.Effect.Symlink , deleteSymlink , testSymlink , runSymlinkIO + , runSymlinkPure + , verifyExistingSymlink , Symlink(..) , SymlinkError(..) ) where @@ -10,10 +12,13 @@ module Confer.Effect.Symlink import Control.Exception import Control.Monad import Control.Placeholder +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Effectful import Effectful.Dispatch.Dynamic 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 (OsPath, FileType(..)) import System.Directory.Internal qualified as Directory @@ -23,6 +28,13 @@ import System.OsPath qualified as OsPath data SymlinkError = DoesNotExist OsPath | IsNotSymlink OsPath + | WrongTarget + OsPath + -- ^ Path to the symbolic link + OsPath + -- ^ Expected target + OsPath + -- ^ Actual target deriving stock (Show, Eq) data Symlink :: Effect where @@ -60,7 +72,7 @@ runSymlinkIO = interpret $ \_ -> \case DeleteSymlink _ -> todo TestSymlink target' -> do target <- liftIO $ OsPath.decodeFS target' - liftIO $ catch ( do + liftIO $ catch (do result <- Directory.pathIsSymbolicLink target if result then pure $ Right () @@ -71,3 +83,32 @@ runSymlinkIO = interpret $ \_ -> \case then pure $ Left (DoesNotExist target') else pure $ Right () ) + +runSymlinkPure + :: Map OsPath OsPath + -> Eff (Symlink : es) a + -> Eff es a +runSymlinkPure virtualFS = reinterpret (State.evalState virtualFS) $ \_ -> \case + CreateSymlink source destination -> + State.modify @(Map OsPath OsPath) (Map.insert source destination) + DeleteSymlink linkPath -> + State.modify @(Map OsPath OsPath) (Map.delete linkPath) + TestSymlink linkPath -> State.gets @(Map OsPath OsPath) (Map.lookup linkPath) >>= \case + Just linkTarget -> pure $ Right () + Nothing -> pure $ Left (DoesNotExist linkPath) + +verifyExistingSymlink + :: (FileSystem :> es) + => FilePath + -> FilePath + -> Eff es (Either SymlinkError ()) +verifyExistingSymlink linkPath expectedLinkTarget = do + actualLinkTarget <- FileSystem.getSymbolicLinkTarget linkPath + if actualLinkTarget == expectedLinkTarget + then pure (Right ()) + else pure $ Left + (WrongTarget + (OsPath.unsafeEncodeUtf linkPath) + (OsPath.unsafeEncodeUtf expectedLinkTarget) + (OsPath.unsafeEncodeUtf actualLinkTarget) + ) diff --git a/test/Main.hs b/test/Main.hs index 3e2059e..ffa16ee 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,8 @@ module Main (main) where +import Test.Tasty +import Test.Tasty.HUnit +import Confer.Cmd.Check + main :: IO () main = putStrLn "Test suite not yet implemented."