diff --git a/src/Confer/Cmd/Check.hs b/src/Confer/Cmd/Check.hs index 84936d2..368e7f1 100644 --- a/src/Confer/Cmd/Check.hs +++ b/src/Confer/Cmd/Check.hs @@ -2,22 +2,30 @@ module Confer.Cmd.Check (check) where import Data.Foldable import Data.Function +import Data.List.NonEmpty +import Data.List.NonEmpty qualified as NE import Data.Text qualified as Text import Data.Text.Display +import Control.Placeholder import Data.Text.IO qualified as Text import Effectful import Effectful.FileSystem (FileSystem) import Effectful.FileSystem qualified as FileSystem +import Control.Monad import System.Info qualified as System -import System.OsPath (()) +import System.OsPath ((), OsPath) import System.OsPath qualified as OsPath +import Validation import Confer.Config.Evaluator import Confer.Config.Types +import Confer.Effect.Symlink (Symlink, SymlinkError) +import Confer.Effect.Symlink qualified as Symlink check :: ( IOE :> es , FileSystem :> es + , Symlink :> es ) => Eff es () check = do @@ -26,10 +34,23 @@ check = do let currentOS = OS (Text.pack System.os) let currentArch = Arch (Text.pack System.arch) let deployments = adjustConfiguration currentOS currentArch allDeployments - forM_ deployments $ \deployment -> - forM_ deployment.facts $ \fact -> do + result <- sequenceA . join <$> mapM (\deployment -> + forM deployment.facts $ \fact -> do liftIO $ Text.putStrLn $ "[+] Checking " <> display fact - let osPath = fact.destination fact.source - filePath <- liftIO $ OsPath.decodeFS osPath - FileSystem.pathIsSymbolicLink filePath + validateSymlink fact) deployments + case result of + Failure errors-> + liftIO $ print errors + Success _ -> pure () Left e -> error e + +validateSymlink + :: (Symlink :> es) + => Fact + -> Eff es (Validation (NonEmpty SymlinkError) ()) +validateSymlink fact = do + let osPath = fact.destination fact.source + result <- Symlink.testSymlink osPath + case result of + Right _ -> pure $ Success () + Left e -> pure $ Failure (NE.singleton e) diff --git a/src/Confer/Effect/Symlink.hs b/src/Confer/Effect/Symlink.hs index 04d676f..cb4aea2 100644 --- a/src/Confer/Effect/Symlink.hs +++ b/src/Confer/Effect/Symlink.hs @@ -1,20 +1,34 @@ module Confer.Effect.Symlink ( createSymlink , deleteSymlink + , testSymlink , runSymlinkIO , Symlink(..) + , SymlinkError(..) ) where import Control.Placeholder import Effectful import Effectful.Dispatch.Dynamic import Effectful.FileSystem -import System.Directory.Internal +import Effectful.FileSystem qualified as FileSystem +import System.Directory qualified as Directory +import System.Directory.Internal qualified as Directory +import System.Directory.Internal (OsPath, FileType(..)) +import System.IO.Error import System.OsPath qualified as OsPath +import Control.Monad +import Control.Exception + +data SymlinkError + = DoesNotExist OsPath + | IsNotSymlink OsPath + deriving stock (Show, Eq) data Symlink :: Effect where CreateSymlink :: OsPath -> OsPath -> Symlink m () DeleteSymlink :: OsPath -> Symlink m () + TestSymlink :: OsPath -> Symlink m (Either SymlinkError ()) type instance DispatchOf Symlink = Dynamic @@ -24,6 +38,9 @@ createSymlink source destination = send (CreateSymlink source destination) deleteSymlink :: (Symlink :> es) => OsPath -> Eff es () deleteSymlink target = send (DeleteSymlink target) +testSymlink :: (Symlink :> es) => OsPath -> Eff es (Either SymlinkError () ) +testSymlink target = send (TestSymlink target) + runSymlinkIO :: (IOE :> es, FileSystem :> es) => Eff (Symlink : es) a @@ -31,8 +48,8 @@ runSymlinkIO runSymlinkIO = interpret $ \_ -> \case CreateSymlink source destination -> do sourceType <- liftIO $ do - metadata <- getFileMetadata source - pure $ fileTypeFromMetadata metadata + metadata <- Directory.getFileMetadata source + pure $ Directory.fileTypeFromMetadata metadata sourcePath <- liftIO $ OsPath.decodeFS source destinationPath <- liftIO $ OsPath.decodeFS destination case sourceType of @@ -41,3 +58,16 @@ runSymlinkIO = interpret $ \_ -> \case Directory -> createDirectoryLink sourcePath destinationPath DeleteSymlink _ -> todo + TestSymlink target' -> do + target <- liftIO $ OsPath.decodeFS target' + liftIO $ catch ( do + result <- Directory.pathIsSymbolicLink target + if result + then pure $ Right () + else pure $ Left (IsNotSymlink target') + ) + (\exception -> do + if isDoesNotExistError exception + then pure $ Left (DoesNotExist target') + else pure $ Right () + )