diff --git a/app/Main.hs b/app/Main.hs index 4343cc5..65d8c71 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,4 @@ -module Main where +module Main (main) where import Commands qualified import ConduitUtils qualified @@ -167,16 +167,17 @@ 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 } - ConduitUtils.runConduitWithProgress files $ - Conduit.mapM_C $ - Commands.fixFilePaths 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 78aa4d9..c8218ec 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,14 @@ library MusicBrainz.Req MusicBrainz.Similarity MusicBrainz.Types - Path.IO.Extra Sound.HTagLib.Extra Toml.Extra build-depends: JuicyPixels, aeson, + bluefin, + containers, extra, file-embed, filepath, @@ -111,6 +114,7 @@ executable htagcli build-depends: ansi-terminal, + bluefin, conduit, extra, filepath, @@ -157,6 +161,7 @@ test-suite tests build-depends: aeson, + bluefin, extra, hedgehog, hspec, diff --git a/lib/Commands.hs b/lib/Commands.hs index e3ce51b..cdf6944 100644 --- a/lib/Commands.hs +++ b/lib/Commands.hs @@ -6,17 +6,21 @@ module Commands checkAlbum, checkArtist, FixFilePathsOptions (..), - fixFilePaths, - 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 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 +29,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,61 +134,72 @@ 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) => +fixFilePath :: + (ex :> es, fs :> es) => + Bluefin.Exception Error ex -> + FileSystem.FileSystem fs -> 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 $ + AudioTrack.AudioTrack -> + Bluefin.Eff es () +fixFilePath + ex + fileSystem + FixFilePathsOptions {..} + track = do + let fromFile = AudioTrack.atFile track + toFile <- + either (Bluefin.throw ex) pure $ + maybeToRight (UnableToFormatFile fromFile) $ + Pattern.toPath fiFormatting track fiPattern + let toFileAbs = fiBaseDirectory toFile + unless (toFileAbs == fromFile) $ do + whenM (FileSystem.doesFileExist fileSystem toFileAbs) $ + Bluefin.throw ex $ TargetFileAlreadyExists toFileAbs - unless fiDryRun $ do - Path.ensureDir $ Path.parent toFileAbs - - Path.renameFile fromFile toFileAbs - - -- Move the cover if there - 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) - - Path.removeDirAndParentsIfEmpty parentDir - - pure (Just toFileAbs) - -fixFilePaths :: - (MonadIO m) => - FixFilePathsOptions -> - Path.Path Path.Abs Path.File -> - m () -fixFilePaths options fromFile = do - mbNewPath <- fixFilePaths' options fromFile - whenJust mbNewPath $ \toFile -> - putTextLn $ - fromString (Path.toFilePath fromFile) - <> " -> " - <> fromString (Path.toFilePath toFile) + FileSystem.ensureDir fileSystem $ Path.parent toFileAbs + FileSystem.printLine fileSystem $ + fromString (Path.toFilePath fromFile) + <> " -> " + <> fromString (Path.toFilePath toFileAbs) + FileSystem.renameFile fileSystem fromFile toFileAbs + + let parentDir = Path.parent fromFile + whenJust fiCoverImages $ \covers -> + forM_ covers $ \cover -> + whenM (FileSystem.doesFileExist fileSystem (parentDir cover)) $ do + let coverFrom = parentDir cover + coverTo = Path.parent toFileAbs cover + FileSystem.printLine fileSystem $ + fromString (Path.toFilePath coverFrom) + <> " -> " + <> fromString (Path.toFilePath 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 new file mode 100644 index 0000000..dff8ed8 --- /dev/null +++ b/lib/Commands/FileSystem.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Commands.FileSystem + ( 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 + +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 -> + 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) () + } + +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 -> + 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) + +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), + ovDeleted :: Set.Set (Path.Path Path.Abs Path.File), + ovDeletedDirs :: Set.Set (Path.Path Path.Abs Path.Dir) + } + +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 9547e76..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 Data.List qualified as List import Model.AudioTrack qualified as AudioTrack import Model.Pattern qualified as Pattern import Model.Tag qualified as Tag @@ -31,13 +30,10 @@ testFixFilePaths = let inputDir = dir filenamesBefore <- snd <$> Path.listDir inputDir - result <- - traverse - (Commands.fixFilePaths' $ fixFilePathsOptions True False inputDir) - filenamesBefore - - -- All files would be renamed - all isJust result `shouldBe` True + 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 @@ -46,12 +42,11 @@ testFixFilePaths = Common.withTenTracksFilesInSubdir [reldir|./input|] $ \dir _ -> do let inputDir = dir [reldir|input|] filenamesInCurrentDirBefore <- snd <$> Path.listDir inputDir - listMbPaths <- - traverse - (Commands.fixFilePaths' $ fixFilePathsOptions False False dir) - filenamesInCurrentDirBefore - all isJust listMbPaths `shouldBe` True + 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 @@ -62,8 +57,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|] @@ -71,31 +65,28 @@ testFixFilePaths = System.writeFile (Path.toFilePath dummy) "dummy content" filenamesInCurrentDirBefore <- - filter (/= dummy) . snd - <$> Path.listDir inputDir - - listMbPaths <- - traverse - (Commands.fixFilePaths' $ fixFilePathsOptions False False dir) - filenamesInCurrentDirBefore + filter (/= dummy) . snd <$> Path.listDir inputDir - all isJust listMbPaths `shouldBe` True + Commands.withFixFilePath False $ \fixPath -> + forM_ filenamesInCurrentDirBefore $ \file -> do + track <- AudioTrack.getTags file + fixPath (fixFilePathsOptions False dir) track 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' $ fixFilePathsOptions False 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, @@ -111,36 +102,42 @@ 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' $ fixFilePathsOptions False 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 - 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 - targetFile <- - Unsafe.fromJust - <$> Commands.fixFilePaths' (fixFilePathsOptions True 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) "" result <- Exception.try $ - Commands.fixFilePaths' (fixFilePathsOptions dryRun False dir) file + 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 ()) @@ -163,11 +160,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|]])