Accumulate validation errors

close #1

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)

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,15 +38,18 @@ 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
   -> Eff es a
 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 ()
+      )