From 5f1b0f69810ab30cbd4fb992016a8fd5a5c291c6 Mon Sep 17 00:00:00 2001 From: jecaro Date: Wed, 1 Jul 2026 14:30:14 +0200 Subject: [PATCH 1/4] Use an overlay over the fs for dry-run --- app/Main.hs | 11 +++-- htagcli.cabal | 4 +- lib/Commands.hs | 67 ++++++++++++++-------------- lib/Commands/FileSystem.hs | 89 ++++++++++++++++++++++++++++++++++++++ tests/Tests/Commands.hs | 27 +++++++----- 5 files changed, 148 insertions(+), 50 deletions(-) create mode 100644 lib/Commands/FileSystem.hs diff --git a/app/Main.hs b/app/Main.hs index 4343cc5..d33e99b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,7 @@ module Main where import Commands qualified +import Commands.FileSystem qualified as FileSystem import ConduitUtils qualified import Config qualified import Data.Conduit.Combinators qualified as Conduit @@ -167,16 +168,20 @@ main = do baseDir <- maybe (pure fiBaseDir) Path.makeAbsolute foBaseDirectory let fixFilePathOptions = Commands.FixFilePathsOptions - { Commands.fiDryRun = foDryRun, - Commands.fiBaseDirectory = baseDir, + { Commands.fiBaseDirectory = baseDir, Commands.fiFormatting = fiFormatting, Commands.fiPattern = pattern, Commands.fiCoverImages = coverImages } + fileSystem <- + if foDryRun + then FileSystem.mkOverlay + else pure FileSystem.mkReal + ConduitUtils.runConduitWithProgress files $ Conduit.mapM_C $ - Commands.fixFilePaths fixFilePathOptions + Commands.fixFilePaths fileSystem fixFilePathOptions Options.Search options -> do case options of Options.SeSearchMany (Options.SearchMany {..}) -> diff --git a/htagcli.cabal b/htagcli.cabal index 78aa4d9..5b23cd0 100644 --- a/htagcli.cabal +++ b/htagcli.cabal @@ -20,6 +20,7 @@ common defaults default-extensions: DataKinds LambdaCase + MultiWayIf OverloadedStrings PackageImports RecordWildCards @@ -53,6 +54,7 @@ library Check.Disc Check.Track Commands + Commands.FileSystem Config Data.List.NonEmpty.Extra Model.Album @@ -68,13 +70,13 @@ library MusicBrainz.Req MusicBrainz.Similarity MusicBrainz.Types - Path.IO.Extra Sound.HTagLib.Extra Toml.Extra build-depends: JuicyPixels, aeson, + containers, extra, file-embed, filepath, diff --git a/lib/Commands.hs b/lib/Commands.hs index e3ce51b..bdd7d54 100644 --- a/lib/Commands.hs +++ b/lib/Commands.hs @@ -17,6 +17,7 @@ import Check.Album qualified as Album import Check.Artist qualified as Artist import Check.Disc qualified as Disc import Check.Track qualified as Track +import Commands.FileSystem qualified as FileSystem import Model.Album qualified as Album import Model.Artist qualified as Artist import Model.AudioTrack qualified as AudioTrack @@ -25,8 +26,6 @@ import Model.Pattern qualified as Pattern import Model.SetTags qualified as SetTags import Path (()) import Path qualified -import Path.IO qualified as Path -import Path.IO.Extra qualified as Path import Sound.HTagLib qualified as HTagLib import Sound.HTagLib.Extra qualified as HTagLib import UnliftIO.Exception qualified as Exception @@ -132,59 +131,57 @@ checkArtist (Just check) artist = do HTagLib.unAlbumArtistOrArtist $ Artist.albumArtistOrArtist artist data FixFilePathsOptions = FixFilePathsOptions - { fiDryRun :: Bool, - fiBaseDirectory :: Path.Path Path.Abs Path.Dir, + { fiBaseDirectory :: Path.Path Path.Abs Path.Dir, fiFormatting :: Pattern.Formatting, fiPattern :: Pattern.Pattern, fiCoverImages :: Maybe (NonEmpty (Path.Path Path.Rel Path.File)) } deriving (Show) --- | Version for testing that returns the new path if changed fixFilePaths' :: (MonadIO m) => + FileSystem.FileSystem m -> FixFilePathsOptions -> Path.Path Path.Abs Path.File -> m (Maybe (Path.Path Path.Abs Path.File)) -fixFilePaths' FixFilePathsOptions {..} fromFile = do - track <- AudioTrack.getTags fromFile - toFile <- - Exception.fromEither $ - maybeToRight (UnableToFormatFile fromFile) $ - Pattern.toPath fiFormatting track fiPattern - let toFileAbs = fiBaseDirectory toFile - if toFileAbs == fromFile - then pure Nothing - else do - whenM (Path.doesFileExist toFileAbs) $ - Exception.throwIO $ - TargetFileAlreadyExists toFileAbs - - unless fiDryRun $ do - Path.ensureDir $ Path.parent toFileAbs - - Path.renameFile fromFile toFileAbs - - -- Move the cover if there +fixFilePaths' + fileSystem@FileSystem.FileSystem {..} + FixFilePathsOptions {..} + fromFile = do + track <- AudioTrack.getTags fromFile + toFile <- + Exception.fromEither $ + maybeToRight (UnableToFormatFile fromFile) $ + Pattern.toPath fiFormatting track fiPattern + let toFileAbs = fiBaseDirectory toFile + if toFileAbs == fromFile + then pure Nothing + else do + whenM (fiDoesFileExist toFileAbs) $ + Exception.throwIO $ + TargetFileAlreadyExists toFileAbs + + fiEnsureDir $ Path.parent toFileAbs + fiRenameFile fromFile toFileAbs + let parentDir = Path.parent fromFile - whenJust fiCoverImages $ \covers -> do - forM_ covers $ \cover -> do - whenM (Path.doesFileExist (parentDir cover)) $ do - Path.renameFile - (parentDir cover) - (Path.parent toFileAbs cover) + whenJust fiCoverImages $ \covers -> + forM_ covers $ \cover -> + whenM (fiDoesFileExist (parentDir cover)) $ + fiRenameFile (parentDir cover) (Path.parent toFileAbs cover) - Path.removeDirAndParentsIfEmpty parentDir + FileSystem.removeDirAndParentsIfEmpty fileSystem parentDir - pure (Just toFileAbs) + pure (Just toFileAbs) fixFilePaths :: (MonadIO m) => + FileSystem.FileSystem m -> FixFilePathsOptions -> Path.Path Path.Abs Path.File -> m () -fixFilePaths options fromFile = do - mbNewPath <- fixFilePaths' options fromFile +fixFilePaths fileSystem options fromFile = do + mbNewPath <- fixFilePaths' fileSystem options fromFile whenJust mbNewPath $ \toFile -> putTextLn $ fromString (Path.toFilePath fromFile) diff --git a/lib/Commands/FileSystem.hs b/lib/Commands/FileSystem.hs new file mode 100644 index 0000000..f85a02a --- /dev/null +++ b/lib/Commands/FileSystem.hs @@ -0,0 +1,89 @@ +module Commands.FileSystem + ( FileSystem (..), + mkReal, + mkOverlay, + removeDirAndParentsIfEmpty, + ) +where + +import Data.Set qualified as Set +import Path qualified +import Path.IO qualified as Path +import UnliftIO.IORef qualified as IORef + +data FileSystem m = FileSystem + { fiDoesFileExist :: Path.Path Path.Abs Path.File -> m Bool, + fiEnsureDir :: Path.Path Path.Abs Path.Dir -> m (), + fiRenameFile :: + Path.Path Path.Abs Path.File -> + Path.Path Path.Abs Path.File -> + m (), + fiIsDirEmpty :: Path.Path Path.Abs Path.Dir -> m Bool, + fiRemoveDir :: Path.Path Path.Abs Path.Dir -> m () + } + +removeDirAndParentsIfEmpty :: + (MonadIO m) => + FileSystem m -> + Path.Path Path.Abs Path.Dir -> + m () +removeDirAndParentsIfEmpty fs@FileSystem {..} dir = + whenM (fiIsDirEmpty dir) $ do + fiRemoveDir dir + let parent = Path.parent dir + when (parent /= dir) $ removeDirAndParentsIfEmpty fs parent + +mkReal :: (MonadIO m) => FileSystem m +mkReal = + FileSystem + { fiDoesFileExist = Path.doesFileExist, + fiEnsureDir = Path.ensureDir, + fiRenameFile = Path.renameFile, + fiIsDirEmpty = \dir -> do + (dirs, files) <- Path.listDir dir + pure $ null dirs && null files, + fiRemoveDir = Path.removeDir + } + +data Overlay = Overlay + { ovAdded :: Set.Set (Path.Path Path.Abs Path.File), + ovDeleted :: Set.Set (Path.Path Path.Abs Path.File), + ovDeletedDirs :: Set.Set (Path.Path Path.Abs Path.Dir) + } + +mkOverlay :: (MonadIO m) => IO (FileSystem m) +mkOverlay = overlayFs <$> IORef.newIORef emptyOverlay + where + emptyOverlay = + Overlay + { ovAdded = Set.empty, + ovDeleted = Set.empty, + ovDeletedDirs = Set.empty + } + +overlayFs :: (MonadIO m) => IORef.IORef Overlay -> FileSystem m +overlayFs ref = FileSystem {..} + where + fiDoesFileExist path = do + Overlay {..} <- IORef.readIORef ref + if + | path `Set.member` ovDeleted -> pure False + | path `Set.member` ovAdded -> pure True + | otherwise -> liftIO $ Path.doesFileExist path + fiEnsureDir _ = pure () + fiRenameFile from to = + IORef.modifyIORef ref $ \overlay -> + overlay + { ovAdded = Set.insert to $ ovAdded overlay, + ovDeleted = Set.insert from $ ovDeleted overlay + } + fiIsDirEmpty dir = do + (realDirs, realFiles) <- liftIO $ Path.listDir dir + Overlay {..} <- IORef.readIORef ref + let vFiles = filter (`Set.notMember` ovDeleted) realFiles + vDirs = filter (`Set.notMember` ovDeletedDirs) realDirs + hasAddedFiles = any ((== dir) . Path.parent) $ Set.toList ovAdded + pure (null vFiles && null vDirs && not hasAddedFiles) + fiRemoveDir dir = + IORef.modifyIORef ref $ \overlay -> + overlay {ovDeletedDirs = Set.insert dir $ ovDeletedDirs overlay} diff --git a/tests/Tests/Commands.hs b/tests/Tests/Commands.hs index 9547e76..ca8ec71 100644 --- a/tests/Tests/Commands.hs +++ b/tests/Tests/Commands.hs @@ -4,6 +4,7 @@ module Tests.Commands (test) where import Check.Track qualified as Track import Commands qualified +import Commands.FileSystem qualified as FileSystem import Data.List qualified as List import Model.AudioTrack qualified as AudioTrack import Model.Pattern qualified as Pattern @@ -31,9 +32,10 @@ testFixFilePaths = let inputDir = dir filenamesBefore <- snd <$> Path.listDir inputDir + fileSystem <- FileSystem.mkOverlay result <- traverse - (Commands.fixFilePaths' $ fixFilePathsOptions True False inputDir) + (Commands.fixFilePaths' fileSystem $ fixFilePathsOptions False inputDir) filenamesBefore -- All files would be renamed @@ -48,7 +50,7 @@ testFixFilePaths = filenamesInCurrentDirBefore <- snd <$> Path.listDir inputDir listMbPaths <- traverse - (Commands.fixFilePaths' $ fixFilePathsOptions False False dir) + (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions False dir) filenamesInCurrentDirBefore all isJust listMbPaths `shouldBe` True @@ -76,7 +78,7 @@ testFixFilePaths = listMbPaths <- traverse - (Commands.fixFilePaths' $ fixFilePathsOptions False False dir) + (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions False dir) filenamesInCurrentDirBefore all isJust listMbPaths `shouldBe` True @@ -94,7 +96,7 @@ testFixFilePaths = <$> Path.listDir inputDir traverse_ - (Commands.fixFilePaths' $ fixFilePathsOptions False False dir) + (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions False dir) filenamesInCurrentDirBefore exists <- Path.doesFileExist cover @@ -116,7 +118,7 @@ testFixFilePaths = listMbPaths <- traverse - (Commands.fixFilePaths' $ fixFilePathsOptions False True dir) + (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions True dir) filenamesInCurrentDirBefore oldCoverExists <- Path.doesFileExist cover @@ -132,15 +134,19 @@ testFixFilePaths = testTargetAlreadyExists :: Bool -> Tasty.Assertion testTargetAlreadyExists dryRun = Common.withOneTrackFile $ \dir file -> do + -- Get the target file path where the file would be moved with the overlay + -- file system + fileSystem <- FileSystem.mkOverlay targetFile <- Unsafe.fromJust - <$> Commands.fixFilePaths' (fixFilePathsOptions True False dir) file + <$> Commands.fixFilePaths' fileSystem (fixFilePathsOptions False dir) file Path.ensureDir $ Path.parent targetFile -- Create a dummy file where the file should be moved System.writeFile (Path.toFilePath targetFile) "" + fileSystem' <- if dryRun then FileSystem.mkOverlay else pure FileSystem.mkReal result <- Exception.try $ - Commands.fixFilePaths' (fixFilePathsOptions dryRun False dir) file + Commands.fixFilePaths' fileSystem' (fixFilePathsOptions False dir) file result `shouldBe` Left (Commands.TargetFileAlreadyExists targetFile) check :: (MonadIO m) => Path.Path Path.Abs Path.File -> m (Either Track.Error ()) @@ -163,11 +169,10 @@ pattern = ] fixFilePathsOptions :: - Bool -> Bool -> Path.Path Path.Abs Path.Dir -> Commands.FixFilePathsOptions -fixFilePathsOptions dryRun moveCover baseDir = + Bool -> Path.Path Path.Abs Path.Dir -> Commands.FixFilePathsOptions +fixFilePathsOptions moveCover baseDir = Commands.FixFilePathsOptions - { fiDryRun = dryRun, - fiBaseDirectory = baseDir [reldir|output|], + { fiBaseDirectory = baseDir [reldir|output|], fiFormatting = Pattern.noFormatting, fiPattern = pattern, fiCoverImages = guard moveCover *> Just (fromList [[relfile|cover.png|]]) From b3202eb2f381ca565fdc1f53efba0e1adf409f87 Mon Sep 17 00:00:00 2001 From: jecaro Date: Wed, 1 Jul 2026 15:35:36 +0200 Subject: [PATCH 2/4] Remove redundant fixFilePath' --- lib/Commands.hs | 60 ++++++++++++------------------ tests/Tests/Commands.hs | 81 +++++++++++++++++------------------------ 2 files changed, 56 insertions(+), 85 deletions(-) diff --git a/lib/Commands.hs b/lib/Commands.hs index bdd7d54..8a0d8f1 100644 --- a/lib/Commands.hs +++ b/lib/Commands.hs @@ -7,7 +7,6 @@ module Commands checkArtist, FixFilePathsOptions (..), fixFilePaths, - fixFilePaths', Error (..), errorToText, ) @@ -138,13 +137,13 @@ data FixFilePathsOptions = FixFilePathsOptions } deriving (Show) -fixFilePaths' :: +fixFilePaths :: (MonadIO m) => FileSystem.FileSystem m -> FixFilePathsOptions -> Path.Path Path.Abs Path.File -> - m (Maybe (Path.Path Path.Abs Path.File)) -fixFilePaths' + m () +fixFilePaths fileSystem@FileSystem.FileSystem {..} FixFilePathsOptions {..} fromFile = do @@ -154,36 +153,23 @@ fixFilePaths' maybeToRight (UnableToFormatFile fromFile) $ Pattern.toPath fiFormatting track fiPattern let toFileAbs = fiBaseDirectory toFile - if toFileAbs == fromFile - then pure Nothing - else do - whenM (fiDoesFileExist toFileAbs) $ - Exception.throwIO $ - TargetFileAlreadyExists toFileAbs - - fiEnsureDir $ Path.parent toFileAbs - fiRenameFile fromFile toFileAbs - - let parentDir = Path.parent fromFile - whenJust fiCoverImages $ \covers -> - forM_ covers $ \cover -> - whenM (fiDoesFileExist (parentDir cover)) $ - fiRenameFile (parentDir cover) (Path.parent toFileAbs cover) - - FileSystem.removeDirAndParentsIfEmpty fileSystem parentDir - - pure (Just toFileAbs) - -fixFilePaths :: - (MonadIO m) => - FileSystem.FileSystem m -> - FixFilePathsOptions -> - Path.Path Path.Abs Path.File -> - m () -fixFilePaths fileSystem options fromFile = do - mbNewPath <- fixFilePaths' fileSystem options fromFile - whenJust mbNewPath $ \toFile -> - putTextLn $ - fromString (Path.toFilePath fromFile) - <> " -> " - <> fromString (Path.toFilePath toFile) + unless (toFileAbs == fromFile) $ do + whenM (fiDoesFileExist toFileAbs) $ + Exception.throwIO $ + TargetFileAlreadyExists toFileAbs + + fiEnsureDir $ Path.parent toFileAbs + fiRenameFile fromFile toFileAbs + + let parentDir = Path.parent fromFile + whenJust fiCoverImages $ \covers -> + forM_ covers $ \cover -> + whenM (fiDoesFileExist (parentDir cover)) $ + fiRenameFile (parentDir cover) (Path.parent toFileAbs cover) + + FileSystem.removeDirAndParentsIfEmpty fileSystem parentDir + + putTextLn $ + fromString (Path.toFilePath fromFile) + <> " -> " + <> fromString (Path.toFilePath toFileAbs) diff --git a/tests/Tests/Commands.hs b/tests/Tests/Commands.hs index ca8ec71..d32b371 100644 --- a/tests/Tests/Commands.hs +++ b/tests/Tests/Commands.hs @@ -5,7 +5,6 @@ module Tests.Commands (test) where import Check.Track qualified as Track import Commands qualified import Commands.FileSystem qualified as FileSystem -import Data.List qualified as List import Model.AudioTrack qualified as AudioTrack import Model.Pattern qualified as Pattern import Model.Tag qualified as Tag @@ -33,13 +32,9 @@ testFixFilePaths = filenamesBefore <- snd <$> Path.listDir inputDir fileSystem <- FileSystem.mkOverlay - result <- - traverse - (Commands.fixFilePaths' fileSystem $ fixFilePathsOptions False inputDir) - filenamesBefore - - -- All files would be renamed - all isJust result `shouldBe` True + traverse_ + (Commands.fixFilePaths fileSystem $ fixFilePathsOptions False inputDir) + filenamesBefore -- No changes visible on disk filenamesAfter <- snd <$> Path.listDir inputDir @@ -48,12 +43,9 @@ testFixFilePaths = Common.withTenTracksFilesInSubdir [reldir|./input|] $ \dir _ -> do let inputDir = dir [reldir|input|] filenamesInCurrentDirBefore <- snd <$> Path.listDir inputDir - listMbPaths <- - traverse - (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions False dir) - filenamesInCurrentDirBefore - - all isJust listMbPaths `shouldBe` True + traverse_ + (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions False dir) + filenamesInCurrentDirBefore -- All files have been moved, 'input' directory doesn't exist anymore exists <- Path.doesDirExist inputDir @@ -64,8 +56,7 @@ testFixFilePaths = checkResults <- traverse check filenamesAfter - lefts checkResults `shouldBe` mempty - List.sort (catMaybes listMbPaths) `shouldBe` List.sort filenamesAfter, + lefts checkResults `shouldBe` mempty, Tasty.testCase "rename but keep non-empty dirs" $ Common.withTenTracksFilesInSubdir [reldir|./input|] $ \dir _ -> do let inputDir = dir [reldir|input|] @@ -73,30 +64,25 @@ testFixFilePaths = System.writeFile (Path.toFilePath dummy) "dummy content" filenamesInCurrentDirBefore <- - filter (/= dummy) . snd - <$> Path.listDir inputDir + filter (/= dummy) . snd <$> Path.listDir inputDir - listMbPaths <- - traverse - (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions False dir) - filenamesInCurrentDirBefore - - all isJust listMbPaths `shouldBe` True + traverse_ + (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions False dir) + filenamesInCurrentDirBefore exists <- Path.doesDirExist inputDir exists `shouldBe` True, - Tasty.testCase "rename but dont move the cover image" $ do + Tasty.testCase "rename but dont move the cover image" $ Common.withTenTracksFilesInSubdir [reldir|./input|] $ \dir _ -> do let inputDir = dir [reldir|input|] cover = inputDir [relfile|cover.jpg|] Path.copyFile [relfile|./data/cover.png|] cover filenamesInCurrentDirBefore <- - filter (/= cover) . snd - <$> Path.listDir inputDir + filter (/= cover) . snd <$> Path.listDir inputDir traverse_ - (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions False dir) + (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions False dir) filenamesInCurrentDirBefore exists <- Path.doesFileExist cover @@ -113,40 +99,39 @@ testFixFilePaths = Path.copyFile [relfile|./data/cover.png|] cover filenamesInCurrentDirBefore <- - filter (/= cover) . snd - <$> Path.listDir inputDir + filter (/= cover) . snd <$> Path.listDir inputDir - listMbPaths <- - traverse - (Commands.fixFilePaths' FileSystem.mkReal $ fixFilePathsOptions True dir) - filenamesInCurrentDirBefore + traverse_ + (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions True dir) + filenamesInCurrentDirBefore oldCoverExists <- Path.doesFileExist cover oldCoverExists `shouldBe` False - let firstRenamedFile = Unsafe.fromJust $ asum listMbPaths - firstDir = Path.parent firstRenamedFile + allFiles <- snd <$> Path.listDirRecur (dir [reldir|output|]) - newCoverExists <- Path.doesFileExist (firstDir relCover) - newCoverExists `shouldBe` True + let coverFiles = filter ((relCover ==) . Path.filename) allFiles + null coverFiles `shouldBe` False ] testTargetAlreadyExists :: Bool -> Tasty.Assertion testTargetAlreadyExists dryRun = Common.withOneTrackFile $ \dir file -> do - -- Get the target file path where the file would be moved with the overlay - -- file system - fileSystem <- FileSystem.mkOverlay - targetFile <- - Unsafe.fromJust - <$> Commands.fixFilePaths' fileSystem (fixFilePathsOptions False dir) file + let opts = fixFilePathsOptions False dir + track <- AudioTrack.getTags file + let targetFile = + Commands.fiBaseDirectory opts + Unsafe.fromJust + ( Pattern.toPath + (Commands.fiFormatting opts) + track + (Commands.fiPattern opts) + ) Path.ensureDir $ Path.parent targetFile -- Create a dummy file where the file should be moved System.writeFile (Path.toFilePath targetFile) "" - fileSystem' <- if dryRun then FileSystem.mkOverlay else pure FileSystem.mkReal - result <- - Exception.try $ - Commands.fixFilePaths' fileSystem' (fixFilePathsOptions False dir) file + fileSystem <- if dryRun then FileSystem.mkOverlay else pure FileSystem.mkReal + result <- Exception.try $ Commands.fixFilePaths fileSystem opts file result `shouldBe` Left (Commands.TargetFileAlreadyExists targetFile) check :: (MonadIO m) => Path.Path Path.Abs Path.File -> m (Either Track.Error ()) From 9dedf396793a7b4a0760091265614808845b3099 Mon Sep 17 00:00:00 2001 From: jecaro Date: Wed, 1 Jul 2026 15:44:13 +0200 Subject: [PATCH 3/4] Print all the filesystem statements --- lib/Commands.hs | 19 ++++++++++++------- lib/Commands/FileSystem.hs | 1 + 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/lib/Commands.hs b/lib/Commands.hs index 8a0d8f1..b8de422 100644 --- a/lib/Commands.hs +++ b/lib/Commands.hs @@ -159,17 +159,22 @@ fixFilePaths TargetFileAlreadyExists toFileAbs fiEnsureDir $ Path.parent toFileAbs + putTextLn $ + fromString (Path.toFilePath fromFile) + <> " -> " + <> fromString (Path.toFilePath toFileAbs) fiRenameFile fromFile toFileAbs let parentDir = Path.parent fromFile whenJust fiCoverImages $ \covers -> forM_ covers $ \cover -> - whenM (fiDoesFileExist (parentDir cover)) $ - fiRenameFile (parentDir cover) (Path.parent toFileAbs cover) + whenM (fiDoesFileExist (parentDir cover)) $ do + let coverFrom = parentDir cover + coverTo = Path.parent toFileAbs cover + putTextLn $ + fromString (Path.toFilePath coverFrom) + <> " -> " + <> fromString (Path.toFilePath coverTo) + fiRenameFile coverFrom coverTo FileSystem.removeDirAndParentsIfEmpty fileSystem parentDir - - putTextLn $ - fromString (Path.toFilePath fromFile) - <> " -> " - <> fromString (Path.toFilePath toFileAbs) diff --git a/lib/Commands/FileSystem.hs b/lib/Commands/FileSystem.hs index f85a02a..fe10ecd 100644 --- a/lib/Commands/FileSystem.hs +++ b/lib/Commands/FileSystem.hs @@ -29,6 +29,7 @@ removeDirAndParentsIfEmpty :: m () removeDirAndParentsIfEmpty fs@FileSystem {..} dir = whenM (fiIsDirEmpty dir) $ do + putTextLn $ fromString (Path.toFilePath dir) <> " (deleted)" fiRemoveDir dir let parent = Path.parent dir when (parent /= dir) $ removeDirAndParentsIfEmpty fs parent From 864a03cfbd1651c5e2e318c3d3aec0e21041e744 Mon Sep 17 00:00:00 2001 From: jecaro Date: Thu, 2 Jul 2026 11:04:04 +0200 Subject: [PATCH 4/4] Use bluefin for fixpath dry-run or not --- app/Main.hs | 16 +-- htagcli.cabal | 3 + lib/Commands.hs | 63 +++++++---- lib/Commands/FileSystem.hs | 223 ++++++++++++++++++++++++++----------- tests/Tests/Commands.hs | 44 ++++---- 5 files changed, 233 insertions(+), 116 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index d33e99b..65d8c71 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,6 @@ -module Main where +module Main (main) where import Commands qualified -import Commands.FileSystem qualified as FileSystem import ConduitUtils qualified import Config qualified import Data.Conduit.Combinators qualified as Conduit @@ -174,14 +173,11 @@ main = do Commands.fiCoverImages = coverImages } - fileSystem <- - if foDryRun - then FileSystem.mkOverlay - else pure FileSystem.mkReal - - ConduitUtils.runConduitWithProgress files $ - Conduit.mapM_C $ - Commands.fixFilePaths fileSystem fixFilePathOptions + Commands.withFixFilePath foDryRun $ \fixFilePath -> + ConduitUtils.runConduitWithProgress files $ + Conduit.mapM_C $ \file -> liftIO $ do + track <- AudioTrack.getTags file + fixFilePath fixFilePathOptions track Options.Search options -> do case options of Options.SeSearchMany (Options.SearchMany {..}) -> diff --git a/htagcli.cabal b/htagcli.cabal index 5b23cd0..c8218ec 100644 --- a/htagcli.cabal +++ b/htagcli.cabal @@ -76,6 +76,7 @@ library build-depends: JuicyPixels, aeson, + bluefin, containers, extra, file-embed, @@ -113,6 +114,7 @@ executable htagcli build-depends: ansi-terminal, + bluefin, conduit, extra, filepath, @@ -159,6 +161,7 @@ test-suite tests build-depends: aeson, + bluefin, extra, hedgehog, hspec, diff --git a/lib/Commands.hs b/lib/Commands.hs index b8de422..cdf6944 100644 --- a/lib/Commands.hs +++ b/lib/Commands.hs @@ -6,12 +6,16 @@ module Commands checkAlbum, checkArtist, FixFilePathsOptions (..), - fixFilePaths, + withFixFilePath, Error (..), errorToText, ) where +import Bluefin.Eff ((:&), (:>)) +import Bluefin.Eff qualified as Bluefin +import Bluefin.Exception qualified as Bluefin +import Bluefin.IO qualified as Bluefin import Check.Album qualified as Album import Check.Artist qualified as Artist import Check.Disc qualified as Disc @@ -137,44 +141,65 @@ data FixFilePathsOptions = FixFilePathsOptions } deriving (Show) -fixFilePaths :: - (MonadIO m) => - FileSystem.FileSystem m -> +fixFilePath :: + (ex :> es, fs :> es) => + Bluefin.Exception Error ex -> + FileSystem.FileSystem fs -> FixFilePathsOptions -> - Path.Path Path.Abs Path.File -> - m () -fixFilePaths - fileSystem@FileSystem.FileSystem {..} + AudioTrack.AudioTrack -> + Bluefin.Eff es () +fixFilePath + ex + fileSystem FixFilePathsOptions {..} - fromFile = do - track <- AudioTrack.getTags fromFile + track = do + let fromFile = AudioTrack.atFile track toFile <- - Exception.fromEither $ + either (Bluefin.throw ex) pure $ maybeToRight (UnableToFormatFile fromFile) $ Pattern.toPath fiFormatting track fiPattern let toFileAbs = fiBaseDirectory toFile unless (toFileAbs == fromFile) $ do - whenM (fiDoesFileExist toFileAbs) $ - Exception.throwIO $ + whenM (FileSystem.doesFileExist fileSystem toFileAbs) $ + Bluefin.throw ex $ TargetFileAlreadyExists toFileAbs - fiEnsureDir $ Path.parent toFileAbs - putTextLn $ + FileSystem.ensureDir fileSystem $ Path.parent toFileAbs + FileSystem.printLine fileSystem $ fromString (Path.toFilePath fromFile) <> " -> " <> fromString (Path.toFilePath toFileAbs) - fiRenameFile fromFile toFileAbs + FileSystem.renameFile fileSystem fromFile toFileAbs let parentDir = Path.parent fromFile whenJust fiCoverImages $ \covers -> forM_ covers $ \cover -> - whenM (fiDoesFileExist (parentDir cover)) $ do + whenM (FileSystem.doesFileExist fileSystem (parentDir cover)) $ do let coverFrom = parentDir cover coverTo = Path.parent toFileAbs cover - putTextLn $ + FileSystem.printLine fileSystem $ fromString (Path.toFilePath coverFrom) <> " -> " <> fromString (Path.toFilePath coverTo) - fiRenameFile coverFrom coverTo + FileSystem.renameFile fileSystem coverFrom coverTo FileSystem.removeDirAndParentsIfEmpty fileSystem parentDir + +withFixFilePath :: + Bool -> + ((FixFilePathsOptions -> AudioTrack.AudioTrack -> IO ()) -> IO r) -> + IO r +withFixFilePath dryRun cont = + Bluefin.runEff_ $ \io -> withFs io $ \fs -> Bluefin.withEffToIO_ io $ \toIO -> + cont $ \opts track -> do + result <- toIO $ Bluefin.try $ \ex -> fixFilePath ex fs opts track + either Exception.throwIO pure result + where + withFs :: + (io :> es) => + Bluefin.IOE io -> + (forall e. FileSystem.FileSystem e -> Bluefin.Eff (e :& es) r') -> + Bluefin.Eff es r' + withFs + | dryRun = FileSystem.withOverlayFileSystem + | otherwise = FileSystem.withRealFileSystem diff --git a/lib/Commands/FileSystem.hs b/lib/Commands/FileSystem.hs index fe10ecd..dff8ed8 100644 --- a/lib/Commands/FileSystem.hs +++ b/lib/Commands/FileSystem.hs @@ -1,50 +1,123 @@ +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + module Commands.FileSystem - ( FileSystem (..), - mkReal, - mkOverlay, + ( FileSystem, + withRealFileSystem, + withOverlayFileSystem, + doesFileExist, + ensureDir, + renameFile, + isDirEmpty, + removeDir, + printLine, removeDirAndParentsIfEmpty, ) where +import Bluefin.Compound qualified as Bluefin +import Bluefin.Eff ((:&), (:>)) +import Bluefin.Eff qualified as Bluefin +import Bluefin.IO qualified as Bluefin +import Bluefin.State qualified as Bluefin import Data.Set qualified as Set import Path qualified import Path.IO qualified as Path -import UnliftIO.IORef qualified as IORef -data FileSystem m = FileSystem - { fiDoesFileExist :: Path.Path Path.Abs Path.File -> m Bool, - fiEnsureDir :: Path.Path Path.Abs Path.Dir -> m (), - fiRenameFile :: +data FileSystem (es :: Bluefin.Effects) = MkFileSystem + { fiDoesFileExistImpl :: + forall e. + Path.Path Path.Abs Path.File -> Bluefin.Eff (e :& es) Bool, + fiEnsureDirImpl :: + forall e. + Path.Path Path.Abs Path.Dir -> Bluefin.Eff (e :& es) (), + fiRenameFileImpl :: + forall e. Path.Path Path.Abs Path.File -> Path.Path Path.Abs Path.File -> - m (), - fiIsDirEmpty :: Path.Path Path.Abs Path.Dir -> m Bool, - fiRemoveDir :: Path.Path Path.Abs Path.Dir -> m () + Bluefin.Eff (e :& es) (), + fiIsDirEmptyImpl :: + forall e. + Path.Path Path.Abs Path.Dir -> Bluefin.Eff (e :& es) Bool, + fiRemoveDirImpl :: + forall e. + Path.Path Path.Abs Path.Dir -> Bluefin.Eff (e :& es) (), + fiPrintLineImpl :: + forall e. + Text -> Bluefin.Eff (e :& es) () } -removeDirAndParentsIfEmpty :: - (MonadIO m) => - FileSystem m -> +instance Bluefin.Handle FileSystem where + mapHandle MkFileSystem {..} = + MkFileSystem + { fiDoesFileExistImpl = Bluefin.useImplUnder . fiDoesFileExistImpl, + fiEnsureDirImpl = Bluefin.useImplUnder . fiEnsureDirImpl, + fiRenameFileImpl = + \from to -> Bluefin.useImplUnder $ fiRenameFileImpl from to, + fiIsDirEmptyImpl = Bluefin.useImplUnder . fiIsDirEmptyImpl, + fiRemoveDirImpl = Bluefin.useImplUnder . fiRemoveDirImpl, + fiPrintLineImpl = Bluefin.useImplUnder . fiPrintLineImpl + } + +doesFileExist :: + (e :> es) => + FileSystem e -> + Path.Path Path.Abs Path.File -> + Bluefin.Eff es Bool +doesFileExist fs = Bluefin.makeOp . fiDoesFileExistImpl (Bluefin.mapHandle fs) + +ensureDir :: + (e :> es) => + FileSystem e -> Path.Path Path.Abs Path.Dir -> - m () -removeDirAndParentsIfEmpty fs@FileSystem {..} dir = - whenM (fiIsDirEmpty dir) $ do - putTextLn $ fromString (Path.toFilePath dir) <> " (deleted)" - fiRemoveDir dir - let parent = Path.parent dir - when (parent /= dir) $ removeDirAndParentsIfEmpty fs parent + Bluefin.Eff es () +ensureDir fs = Bluefin.makeOp . fiEnsureDirImpl (Bluefin.mapHandle fs) + +renameFile :: + (e :> es) => + FileSystem e -> + Path.Path Path.Abs Path.File -> + Path.Path Path.Abs Path.File -> + Bluefin.Eff es () +renameFile fs from to = + Bluefin.makeOp $ fiRenameFileImpl (Bluefin.mapHandle fs) from to + +isDirEmpty :: + (e :> es) => + FileSystem e -> + Path.Path Path.Abs Path.Dir -> + Bluefin.Eff es Bool +isDirEmpty fs = Bluefin.makeOp . fiIsDirEmptyImpl (Bluefin.mapHandle fs) + +removeDir :: + (e :> es) => + FileSystem e -> + Path.Path Path.Abs Path.Dir -> + Bluefin.Eff es () +removeDir fs = Bluefin.makeOp . fiRemoveDirImpl (Bluefin.mapHandle fs) -mkReal :: (MonadIO m) => FileSystem m -mkReal = - FileSystem - { fiDoesFileExist = Path.doesFileExist, - fiEnsureDir = Path.ensureDir, - fiRenameFile = Path.renameFile, - fiIsDirEmpty = \dir -> do - (dirs, files) <- Path.listDir dir - pure $ null dirs && null files, - fiRemoveDir = Path.removeDir - } +printLine :: + (e :> es) => + FileSystem e -> + Text -> + Bluefin.Eff es () +printLine fs = Bluefin.makeOp . fiPrintLineImpl (Bluefin.mapHandle fs) + +withRealFileSystem :: + (io :> es) => + Bluefin.IOE io -> + (forall e. FileSystem e -> Bluefin.Eff (e :& es) r) -> + Bluefin.Eff es r +withRealFileSystem ioe action = Bluefin.useImplIn action MkFileSystem {..} + where + fiDoesFileExistImpl = Bluefin.effIO ioe . Path.doesFileExist + fiEnsureDirImpl = Bluefin.effIO ioe . Path.ensureDir + fiRenameFileImpl from to = Bluefin.effIO ioe $ Path.renameFile from to + fiIsDirEmptyImpl dir = Bluefin.effIO ioe $ do + (dirs, files) <- Path.listDir dir + pure $ null dirs && null files + fiRemoveDirImpl = Bluefin.effIO ioe . Path.removeDir + fiPrintLineImpl = Bluefin.effIO ioe . putTextLn data Overlay = Overlay { ovAdded :: Set.Set (Path.Path Path.Abs Path.File), @@ -52,39 +125,53 @@ data Overlay = Overlay ovDeletedDirs :: Set.Set (Path.Path Path.Abs Path.Dir) } -mkOverlay :: (MonadIO m) => IO (FileSystem m) -mkOverlay = overlayFs <$> IORef.newIORef emptyOverlay - where - emptyOverlay = - Overlay - { ovAdded = Set.empty, - ovDeleted = Set.empty, - ovDeletedDirs = Set.empty - } - -overlayFs :: (MonadIO m) => IORef.IORef Overlay -> FileSystem m -overlayFs ref = FileSystem {..} - where - fiDoesFileExist path = do - Overlay {..} <- IORef.readIORef ref - if - | path `Set.member` ovDeleted -> pure False - | path `Set.member` ovAdded -> pure True - | otherwise -> liftIO $ Path.doesFileExist path - fiEnsureDir _ = pure () - fiRenameFile from to = - IORef.modifyIORef ref $ \overlay -> - overlay - { ovAdded = Set.insert to $ ovAdded overlay, - ovDeleted = Set.insert from $ ovDeleted overlay - } - fiIsDirEmpty dir = do - (realDirs, realFiles) <- liftIO $ Path.listDir dir - Overlay {..} <- IORef.readIORef ref - let vFiles = filter (`Set.notMember` ovDeleted) realFiles - vDirs = filter (`Set.notMember` ovDeletedDirs) realDirs - hasAddedFiles = any ((== dir) . Path.parent) $ Set.toList ovAdded - pure (null vFiles && null vDirs && not hasAddedFiles) - fiRemoveDir dir = - IORef.modifyIORef ref $ \overlay -> - overlay {ovDeletedDirs = Set.insert dir $ ovDeletedDirs overlay} +emptyOverlay :: Overlay +emptyOverlay = Overlay Set.empty Set.empty Set.empty + +withOverlayFileSystem :: + (io :> es) => + Bluefin.IOE io -> + (forall e. FileSystem e -> Bluefin.Eff (e :& es) r) -> + Bluefin.Eff es r +withOverlayFileSystem ioe action = + Bluefin.evalState emptyOverlay $ \st -> do + let fiDoesFileExistImpl path = do + Overlay {..} <- Bluefin.get st + if + | path `Set.member` ovDeleted -> pure False + | path `Set.member` ovAdded -> pure True + | otherwise -> Bluefin.effIO ioe $ Path.doesFileExist path + fiEnsureDirImpl = const $ pure () + fiRenameFileImpl from to = + Bluefin.modify st $ \overlay -> + overlay + { ovAdded = Set.insert to $ ovAdded overlay, + ovDeleted = Set.insert from $ ovDeleted overlay + } + fiIsDirEmptyImpl dir = do + (realDirs, realFiles) <- Bluefin.effIO ioe $ Path.listDir dir + Overlay {..} <- Bluefin.get st + let vFiles = filter (`Set.notMember` ovDeleted) realFiles + vDirs = filter (`Set.notMember` ovDeletedDirs) realDirs + hasAddedFiles = any ((== dir) . Path.parent) $ Set.toList ovAdded + pure (null vFiles && null vDirs && not hasAddedFiles) + fiRemoveDirImpl dir = + Bluefin.modify st $ \overlay -> + overlay + { ovDeletedDirs = Set.insert dir $ ovDeletedDirs overlay + } + fiPrintLineImpl = Bluefin.effIO ioe . putTextLn + + Bluefin.useImplIn action MkFileSystem {..} + +removeDirAndParentsIfEmpty :: + (e :> es) => + FileSystem e -> + Path.Path Path.Abs Path.Dir -> + Bluefin.Eff es () +removeDirAndParentsIfEmpty fs dir = + whenM (isDirEmpty fs dir) $ do + printLine fs $ fromString (Path.toFilePath dir) <> " (deleted)" + removeDir fs dir + let parent = Path.parent dir + when (parent /= dir) $ removeDirAndParentsIfEmpty fs parent diff --git a/tests/Tests/Commands.hs b/tests/Tests/Commands.hs index d32b371..af9508d 100644 --- a/tests/Tests/Commands.hs +++ b/tests/Tests/Commands.hs @@ -4,7 +4,6 @@ module Tests.Commands (test) where import Check.Track qualified as Track import Commands qualified -import Commands.FileSystem qualified as FileSystem import Model.AudioTrack qualified as AudioTrack import Model.Pattern qualified as Pattern import Model.Tag qualified as Tag @@ -31,10 +30,10 @@ testFixFilePaths = let inputDir = dir filenamesBefore <- snd <$> Path.listDir inputDir - fileSystem <- FileSystem.mkOverlay - traverse_ - (Commands.fixFilePaths fileSystem $ fixFilePathsOptions False inputDir) - filenamesBefore + Commands.withFixFilePath True $ \fixPath -> + forM_ filenamesBefore $ \file -> do + track <- AudioTrack.getTags file + fixPath (fixFilePathsOptions False inputDir) track -- No changes visible on disk filenamesAfter <- snd <$> Path.listDir inputDir @@ -43,9 +42,11 @@ testFixFilePaths = Common.withTenTracksFilesInSubdir [reldir|./input|] $ \dir _ -> do let inputDir = dir [reldir|input|] filenamesInCurrentDirBefore <- snd <$> Path.listDir inputDir - traverse_ - (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions False dir) - filenamesInCurrentDirBefore + + Commands.withFixFilePath False $ \fixPath -> + forM_ filenamesInCurrentDirBefore $ \file -> do + track <- AudioTrack.getTags file + fixPath (fixFilePathsOptions False dir) track -- All files have been moved, 'input' directory doesn't exist anymore exists <- Path.doesDirExist inputDir @@ -66,9 +67,10 @@ testFixFilePaths = filenamesInCurrentDirBefore <- filter (/= dummy) . snd <$> Path.listDir inputDir - traverse_ - (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions False dir) - filenamesInCurrentDirBefore + Commands.withFixFilePath False $ \fixPath -> + forM_ filenamesInCurrentDirBefore $ \file -> do + track <- AudioTrack.getTags file + fixPath (fixFilePathsOptions False dir) track exists <- Path.doesDirExist inputDir exists `shouldBe` True, @@ -81,9 +83,10 @@ testFixFilePaths = filenamesInCurrentDirBefore <- filter (/= cover) . snd <$> Path.listDir inputDir - traverse_ - (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions False dir) - filenamesInCurrentDirBefore + Commands.withFixFilePath False $ \fixPath -> + forM_ filenamesInCurrentDirBefore $ \file -> do + track <- AudioTrack.getTags file + fixPath (fixFilePathsOptions False dir) track exists <- Path.doesFileExist cover exists `shouldBe` True, @@ -101,9 +104,10 @@ testFixFilePaths = filenamesInCurrentDirBefore <- filter (/= cover) . snd <$> Path.listDir inputDir - traverse_ - (Commands.fixFilePaths FileSystem.mkReal $ fixFilePathsOptions True dir) - filenamesInCurrentDirBefore + Commands.withFixFilePath False $ \fixPath -> + forM_ filenamesInCurrentDirBefore $ \file -> do + track <- AudioTrack.getTags file + fixPath (fixFilePathsOptions True dir) track oldCoverExists <- Path.doesFileExist cover oldCoverExists `shouldBe` False @@ -130,8 +134,10 @@ testTargetAlreadyExists dryRun = Path.ensureDir $ Path.parent targetFile -- Create a dummy file where the file should be moved System.writeFile (Path.toFilePath targetFile) "" - fileSystem <- if dryRun then FileSystem.mkOverlay else pure FileSystem.mkReal - result <- Exception.try $ Commands.fixFilePaths fileSystem opts file + result <- + Exception.try $ + Commands.withFixFilePath dryRun $ \fixPath -> + fixPath opts track result `shouldBe` Left (Commands.TargetFileAlreadyExists targetFile) check :: (MonadIO m) => Path.Path Path.Abs Path.File -> m (Either Track.Error ())