diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# Librarian + +Move/rename according a set of rules. + +## Example + +With `example/cctv.dhall`: + +```dhall +let L = ../format.dhall + +in [ L.Rule::{ + , name = "All footages" + , match = "CCTV/**/*.*m*" + , actions = + [ L.Action.Type.Move + { inputPattern = "CCTV/(.*)/(\\d+)\\.mp4" + , newName = "sorted/\\2/\\1.mp4" + } + ] + } + ] +``` + +``` +$ librarian -r examples/cctv.dhall +Move [All footages] './CCTV/garage/220520.mp4' -> './sorted/220520/garage.mp4' +Move [All footages] './CCTV/garage/220521.mp4' -> './sorted/220521/garage.mp4' +Move [All footages] './CCTV/garage/220522.mp4' -> './sorted/220522/garage.mp4' +Move [All footages] './CCTV/garage/220523.mp4' -> './sorted/220523/garage.mp4' +Move [All footages] './CCTV/garden/220520.mp4' -> './sorted/220520/garden.mp4' +Move [All footages] './CCTV/garden/220521.mp4' -> './sorted/220521/garden.mp4' +Move [All footages] './CCTV/garden/220522.mp4' -> './sorted/220522/garden.mp4' +Move [All footages] './CCTV/garden/220523.mp4' -> './sorted/220523/garden.mp4' +Perform? (y/n) +``` diff --git a/app/Convert.hs b/app/Convert.hs new file mode 100644 --- /dev/null +++ b/app/Convert.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Convert (convert) where + +import Data.Foldable (Foldable (foldl')) +import Data.Time (UTCTime) +import qualified DhallTypes as S +import qualified Librarian as T + +convert :: S.Rule -> T.Rule +convert x = + T.Rule + { name = T.RuleName x.name.getRuleName, + match = T.Matcher x.match.matchPattern, + grouping = convertGrouping x.grouping, + filtering = convertFiltering x.filtering, + actions = convertAction <$> x.actions + } + +convertGrouping :: S.Grouping -> T.Grouping +convertGrouping = + \case + S.FileGroup -> T.FileGroup + S.GroupTemporally source bucket selection -> + T.Group + { groupSource = convertSourceTemporal source, + groupBucket = convertGroupingBucketTemporal bucket, + groupSelection = convertGroupSelectionTemporal selection + } + +convertFiltering :: S.Filtering -> T.Filtering +convertFiltering = + \case + S.All -> T.AllF + S.Ands xs -> foldl' T.AndF T.AllF $ map convertFilteringCondition xs + S.Ors xs -> foldl' T.OrF T.AllF $ map convertFilteringCondition xs + where + convertFilteringCondition = + \case + S.GtTemporalF x y -> T.GtF (convertSourceTemporal x) (convertSourceTemporal y) + S.LtTemporalF x y -> T.LtF (convertSourceTemporal x) (convertSourceTemporal y) + +convertAction :: S.Action -> T.Action +convertAction = + \case + S.Move {..} -> T.Move {inputPattern = inputPattern, newName = newName} + S.Copy {..} -> T.Copy {inputPattern = inputPattern, newName = newName} + S.Remove {..} -> T.Remove {inputPattern = inputPattern} + +convertSourceTemporal :: S.SourceTemporal -> T.Source UTCTime +convertSourceTemporal = + \case + S.SourceDate x -> T.SourceDate $ convertSourceDate x + S.SourceTime x -> T.SourceTime $ convertTimeSpec x + +convertGroupingBucketTemporal :: S.GroupingBucketTemporal -> T.GroupingBucket UTCTime +convertGroupingBucketTemporal = + \case + S.Daily -> T.Daily + S.Weekly -> T.Weekly + S.Monthly -> T.Monthly + +convertGroupSelectionTemporal :: S.GroupSelectionTemporal -> T.GroupSelection UTCTime +convertGroupSelectionTemporal = + \case + S.AfterTemporal index sortingOrder source -> + T.After index (convertSortingOrder sortingOrder) (convertSourceTemporal source) + S.BeforeTemporal index sortingOrder source -> + T.Before index (convertSortingOrder sortingOrder) (convertSourceTemporal source) + where + convertSortingOrder = + \case + S.SortingAsc -> T.SortingAsc + S.SortingDesc -> T.SortingDesc + +convertSourceDate :: S.SourceDate -> T.SourceDate +convertSourceDate = + \case + S.ModificationTime -> T.ModificationTime + S.AccessTime -> T.AccessTime + +convertTimeSpec :: S.TimeSpec -> T.TimeSpec +convertTimeSpec = + \case + S.HoursAgo x -> T.HoursAgo x + S.DaysAgo x -> T.DaysAgo x + S.AbsoluteTime x -> T.AbsoluteTime x diff --git a/app/DhallTypes.hs b/app/DhallTypes.hs new file mode 100644 --- /dev/null +++ b/app/DhallTypes.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +module DhallTypes + ( Rule (..), + RuleName (..), + Grouping (..), + Filtering (..), + FilteringCondition (..), + SourceTemporal (..), + SourceDate (..), + TimeSpec (..), + SortingOrder (..), + GroupSelectionTemporal (..), + GroupingBucketTemporal (..), + + -- * Collecting + Matcher (..), + Action (..), + ) +where + +import Data.String (IsString) +import Data.Time (UTCTime) +import Dhall + +newtype RuleName = RuleName {getRuleName :: String} + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, IsString, FromDhall) + +newtype Matcher = Matcher {matchPattern :: String} + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, IsString, FromDhall) + +data Action + = Move {inputPattern :: String, newName :: String} + | Copy {inputPattern :: String, newName :: String} + | Remove {inputPattern :: String} + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall Action + +data Grouping + = FileGroup + | GroupTemporally + { sourceTemporal :: SourceTemporal, + groupingBucketTemporal :: GroupingBucketTemporal, + groupSelectionTemporal :: GroupSelectionTemporal + } + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall Grouping + +data SourceTemporal + = SourceDate SourceDate + | SourceTime TimeSpec + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall SourceTemporal + +data SourceDate + = ModificationTime + | AccessTime + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall SourceDate + +data TimeSpec + = HoursAgo Integer + | DaysAgo Integer + | AbsoluteTime UTCTime + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall TimeSpec + +data SortingOrder + = SortingAsc + | SortingDesc + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall SortingOrder + +data GroupSelectionTemporal + = AfterTemporal {index :: Int, order :: SortingOrder, sourceTemporal :: SourceTemporal} + | BeforeTemporal {index :: Int, order :: SortingOrder, sourceTemporal :: SourceTemporal} + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall GroupSelectionTemporal + +data GroupingBucketTemporal + = Daily + | Weekly + | Monthly + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall GroupingBucketTemporal + +data FilteringCondition + = GtTemporalF SourceTemporal SourceTemporal + | LtTemporalF SourceTemporal SourceTemporal + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall FilteringCondition + +data Filtering + = All + | Ands [FilteringCondition] + | Ors [FilteringCondition] + deriving stock (Eq, Show, Generic) + +deriving anyclass instance FromDhall Filtering + +data Rule = Rule + { name :: RuleName, + match :: Matcher, + grouping :: Grouping, + filtering :: Filtering, + actions :: [Action] + } + deriving stock (Generic) + +deriving anyclass instance FromDhall Rule diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,33 +1,62 @@ -module Main where +module Main (main) where +import Convert (convert) +import qualified Data.Either.Validation as V +import qualified Data.Text.IO as Text.IO import qualified Dhall as Dhall +import qualified Dhall.Core +import DhallTypes as DhallTypes import Librarian import Options.Applicative as Options +import System.Directory (withCurrentDirectory) main :: IO () main = do args <- parseArgs - rules <- Dhall.inputFile (Dhall.auto @[Rule]) $ rulesFile args - plan <- planMoves <$> fetchRulesOn "." rules - displayPlan plan - putStrLn "Move? (y/n)" - response <- getChar - case response of - 'y' -> do - putStrLn "Proceeding" - runPlan plan >>= displayResult - putStrLn "Done." - _ -> putStrLn "Aborting" + case args of + Format -> + case Dhall.expected (Dhall.auto @[DhallTypes.Rule]) of + V.Success result -> Text.IO.putStrLn (Dhall.Core.pretty result) + V.Failure errors -> print errors + Run (RunArgs {..}) -> do + rules <- map convert <$> Dhall.inputFile (Dhall.auto @[DhallTypes.Rule]) rulesFile + maybe id withCurrentDirectory runRoot $ do + plan <- planActions <$> fetchRulesOn "." rules + displayPlan plan + case plan of + [] -> putStrLn "Nothing to do" + _ -> do + putStrLn "Perform? (y/n)" + response <- getChar + case response of + 'y' -> do + putStrLn "Proceeding" + runPlan plan >>= displayResult + putStrLn "Done." + _ -> putStrLn "Aborting" parseArgs :: IO Args parseArgs = - execParser $ - info (argsParser <**> helper) (fullDesc <> header "Librarian: moving files, your rules!") + customExecParser (prefs showHelpOnEmpty) $ + info (argsParser <**> helper) (fullDesc <> header "Librarian: manage files, your rules!") where argsParser :: Parser Args argsParser = - Args + hsubparser + ( command "dump-dhall-format" (info (pure Format) (progDesc "Dump Dhall format")) + <> command "run" (info (Run <$> runP) (progDesc "Run the rules")) + ) + runP :: Parser RunArgs + runP = + RunArgs <$> strOption (long "rules" <> short 'r' <> metavar "FILE_PATH" <> help "Rules file (.dhall)") + <*> optional (strOption $ long "root" <> short 'd' <> metavar "ROOT_DIRECTORY" <> help "Root directory where the rules are ran (not read)") -newtype Args = Args {rulesFile :: FilePath} +data Args = Format | Run RunArgs + deriving stock (Eq, Ord, Show) + +data RunArgs = RunArgs + { rulesFile :: FilePath, + runRoot :: Maybe FilePath + } deriving stock (Eq, Ord, Show) diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,6 @@ +# Librarian + +## 0.1.0.1 + +* @blackheaven + * Fix cross-devices `Move` diff --git a/librarian.cabal b/librarian.cabal --- a/librarian.cabal +++ b/librarian.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: librarian -version: 0.1.0.0 +version: 0.1.0.1 author: Gautier DI FOLCO maintainer: gautier.difolco@gmail.com category: Data @@ -10,19 +10,22 @@ synopsis: Move/rename according a set of rules description: Move/rename according a set of rules. Homepage: http://github.com/blackheaven/librarian -tested-with: GHC==9.2.2 +tested-with: GHC==9.2.8 +extra-doc-files: + README.md + changelog.md library default-language: Haskell2010 build-depends: base == 4.* , containers - , dhall , directory , easy-file , Glob , pretty-show , regexpr + , time hs-source-dirs: src exposed-modules: Librarian @@ -84,6 +87,7 @@ TypeFamilies TypeOperators ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -- ghc-options: -Werror -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints build-depends: base , librarian @@ -95,12 +99,16 @@ , hspec-core , hspec-discover , temporary + , time default-language: Haskell2010 -executable librarian +executable librarian-exe -- type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: app + other-modules: + Convert + DhallTypes default-extensions: DataKinds DefaultSignatures @@ -127,6 +135,10 @@ build-depends: base , librarian - , dhall + , dhall == 1.* + , directory + , either == 5.* , optparse-applicative + , text + , time default-language: Haskell2010 diff --git a/src/Librarian.hs b/src/Librarian.hs --- a/src/Librarian.hs +++ b/src/Librarian.hs @@ -1,20 +1,33 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + module Librarian ( Rule (..), RuleName (..), + Grouping (..), + Filtering (..), + Source (..), + SourceDate (..), + TimeSpec (..), + SortingOrder (..), + GroupSelection (..), + GroupingBucket (..), -- * Collecting Matcher (..), - Mover (..), + Action (..), CollectedFiles, fetchRulesOn, -- * Planning - Move (..), - planMoves, + ResolvedAction (..), + planActions, displayPlan, -- * Runner - Action (..), + FsAction (..), ActionResult (..), RunResult, runPlan, @@ -24,123 +37,306 @@ import Control.Exception (catch) import Control.Monad -import Data.Function (on) -import Data.Functor (($>)) -import Data.List (find, nubBy, sortOn) +import Data.Foldable (Foldable (toList)) +import Data.Functor (($>), (<&>)) +import Data.Kind (Type) +import Data.List (sortOn) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Ord (Down (Down)) +import Data.Sequence (Seq) import Data.String (IsString) -import Dhall (FromDhall) +import Data.Time + ( UTCTime, + addUTCTime, + defaultTimeLocale, + formatTime, + getCurrentTime, + nominalDay, + secondsToNominalDiffTime, + ) import GHC.Generics (Generic) -import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) +import System.Directory + ( copyFile, + copyFileWithMetadata, + createDirectoryIfMissing, + doesFileExist, + getAccessTime, + getModificationTime, + removeFile, + renameFile, + ) import System.EasyFile (splitFileName) import System.FilePath.Glob (compile, globDir) import Text.RegexPR -import Text.Show.Pretty data Rule = Rule { name :: RuleName, match :: Matcher, - movers :: [Mover] + grouping :: Grouping, + filtering :: Filtering, + actions :: [Action] } - deriving stock (Eq, Show, Generic) - -instance FromDhall Rule + deriving stock (Show, Generic) newtype RuleName = RuleName {getRuleName :: String} deriving stock (Generic) deriving newtype (Eq, Ord, Show, IsString) - deriving (FromDhall) via String newtype Matcher = Matcher {matchPattern :: String} deriving stock (Generic) deriving newtype (Eq, Ord, Show, IsString) - deriving (FromDhall) via String -data Mover = Mover - { inputPattern :: String, - newName :: String - } +data Action + = Move {inputPattern :: String, newName :: String} + | Copy {inputPattern :: String, newName :: String} + | Remove {inputPattern :: String} deriving stock (Eq, Show, Generic) -instance FromDhall Mover +data Grouping + = FileGroup + | forall a. + Ord a => + Group + { groupSource :: Source a, + groupBucket :: GroupingBucket a, + groupSelection :: GroupSelection a + } -type CollectedFiles = Map.Map FilePath Rule +deriving stock instance Show Grouping +data Filtering + = AllF + | AndF Filtering Filtering + | OrF Filtering Filtering + | forall a. Ord a => GtF (Source a) (Source a) + | forall a. Ord a => LtF (Source a) (Source a) + +deriving stock instance Show Filtering + +data Source :: Type -> Type where + SourceDate :: SourceDate -> Source UTCTime + SourceTime :: TimeSpec -> Source UTCTime + +deriving stock instance Eq (Source a) + +deriving stock instance Show (Source a) + +data SourceDate + = ModificationTime + | AccessTime + deriving stock (Eq, Show, Generic) + +data TimeSpec + = HoursAgo Integer + | DaysAgo Integer + | AbsoluteTime UTCTime + deriving stock (Eq, Show, Generic) + +data SortingOrder + = SortingAsc + | SortingDesc + deriving stock (Eq, Show, Generic) + +data GroupSelection a + = After Int SortingOrder (Source a) + | Before Int SortingOrder (Source a) + deriving stock (Eq, Show, Generic) + +data GroupingBucket :: Type -> Type where + Daily :: GroupingBucket UTCTime + Weekly :: GroupingBucket UTCTime + Monthly :: GroupingBucket UTCTime + +deriving stock instance Eq (GroupingBucket a) + +deriving stock instance Show (GroupingBucket a) + +type CollectedFiles = Map.Map FilePath (Seq Rule) + fetchRulesOn :: FilePath -> [Rule] -> IO CollectedFiles fetchRulesOn root rules = do matches <- globDir (compile . matchPattern . match <$> rules) root - let distributeRule :: [FilePath] -> Rule -> [(FilePath, Rule)] - distributeRule fs r = map (\f -> (f, r)) fs + let applyRule :: [FilePath] -> Rule -> IO [(FilePath, Seq Rule)] + applyRule files rule = + filterM (applyFiltering rule.filtering) files + >>= applyGrouping rule + applyFiltering :: Filtering -> FilePath -> IO Bool + applyFiltering filteringRule file = + case filteringRule of + AllF -> return True + AndF x y -> (&&) <$> applyFiltering x file <*> applyFiltering y file + OrF x y -> (||) <$> applyFiltering x file <*> applyFiltering y file + GtF x y -> (>) <$> fetchSource x file <*> fetchSource y file + LtF x y -> (<) <$> fetchSource x file <*> fetchSource y file + applyGrouping :: Rule -> [FilePath] -> IO [(FilePath, Seq Rule)] + applyGrouping rule files = + case rule.grouping of + FileGroup -> + return $ map (\f -> (f, [rule])) files + Group {..} -> do + let bucketUtc :: UTCTime -> String + bucketUtc x = + case groupBucket of + Daily -> formatTime defaultTimeLocale "%Y-%m-%d" x + Weekly -> formatTime defaultTimeLocale "%Y-%V" x + Monthly -> formatTime defaultTimeLocale "%Y-%m" x + bucket :: Source x -> x -> String + bucket source x = + case source of + SourceDate _ -> bucketUtc x + SourceTime _ -> bucketUtc x + fetchBucket :: Source x -> FilePath -> IO String + fetchBucket source file = + bucket source <$> fetchSource source file + sorting :: Ord x => SortingOrder -> [(x, FilePath)] -> [(x, FilePath)] + sorting = + \case + SortingAsc -> sortOn fst + SortingDesc -> sortOn $ Down . fst + applySelection :: [FilePath] -> IO [FilePath] + applySelection bucketedFiles = + case groupSelection of + After n order source -> + drop (n + 1) . map snd . sorting order + <$> mapM (\file -> (,file) <$> fetchSource source file) bucketedFiles + Before n order source -> + take n . map snd . sorting order + <$> mapM (\file -> (,file) <$> fetchSource source file) bucketedFiles + buckets <- + Map.fromListWith @String @(Seq FilePath) (<>) + <$> forM files (\file -> (,[file]) <$> fetchBucket groupSource file) + concatMap (map (,[rule])) + <$> mapM applySelection (toList <$> Map.elems buckets) + fetchSource :: Source a -> FilePath -> IO a + fetchSource source file = + case source of + SourceDate sourceDate -> + case sourceDate of + ModificationTime -> getModificationTime file + AccessTime -> getAccessTime file + SourceTime timeSpec -> + case timeSpec of + HoursAgo d -> + addUTCTime (secondsToNominalDiffTime $ (-1) * fromInteger d * 60 * 60) <$> getCurrentTime + DaysAgo d -> + addUTCTime ((-1) * fromInteger d * nominalDay) <$> getCurrentTime + AbsoluteTime x -> + return x files <- mapM (filterM doesFileExist) matches - return $ Map.unions $ map Map.fromList $ zipWith distributeRule files rules + Map.unionsWith (<>) . map Map.fromList <$> zipWithM applyRule files rules -data Move = Move - { original :: FilePath, - new :: Maybe FilePath, - rule :: Rule - } - deriving stock (Eq, Show, Generic) +data ResolvedAction + = ResolvedMove {original :: FilePath, new :: FilePath, rule :: Rule} + | ResolvedCopy {original :: FilePath, new :: FilePath, rule :: Rule} + | ResolvedRemove {original :: FilePath, rule :: Rule} + deriving stock (Show, Generic) -planMoves :: CollectedFiles -> [Move] -planMoves = map (uncurry planMove) . Map.toList +planActions :: CollectedFiles -> [ResolvedAction] +planActions = concatMap (take 1 . uncurry planAction) . concatMap (traverse toList) . Map.toList where - planMove :: FilePath -> Rule -> Move - planMove p rule = - Move - { original = p, - new = newPath p $ movers rule, - rule = rule - } - newPath :: FilePath -> [Mover] -> Maybe FilePath - newPath p = - fmap (\mover -> subRegexPR (inputPattern mover) (newName mover) p) - . find (isJust . flip matchRegexPR p . inputPattern) + planAction :: FilePath -> Rule -> [ResolvedAction] + planAction p rule = mapMaybe go $ actions rule + where + go :: Action -> Maybe ResolvedAction + go = + \case + Move {..} -> + newPath inputPattern newName + <&> \newPath' -> ResolvedMove {original = p, new = newPath', rule = rule} + Copy {..} -> + newPath inputPattern newName + <&> \newPath' -> ResolvedCopy {original = p, new = newPath', rule = rule} + Remove {..} -> + matchRegexPR inputPattern p + $> ResolvedRemove {original = p, rule = rule} + newPath :: String -> String -> Maybe FilePath + newPath inputPattern' newName' = + mfilter (/= p) $ Just $ subRegexPR inputPattern' newName' p -displayPlan :: [Move] -> IO () -displayPlan xs = do - forM_ xs $ \Move {..} -> - putStrLn $ "[" <> getRuleName (name rule) <> "] '" <> original <> "' -> '" <> fromMaybe "UNABLE TO REPLACE" new <> "'" - let unrenamed = nubBy ((==) `on` name) $ sortOn name $ map rule $ filter (isNothing . new) xs - unless (null unrenamed) $ do - putStrLn "Unable to generate a new name for:" - forM_ unrenamed pPrint +displayPlan :: [ResolvedAction] -> IO () +displayPlan = + mapM_ $ \case + ResolvedMove {..} -> + putStrLn $ "Move [" <> getRuleName (name rule) <> "] '" <> original <> "' -> '" <> new <> "'" + ResolvedCopy {..} -> + putStrLn $ "Copy [" <> getRuleName (name rule) <> "] '" <> original <> "' -> '" <> new <> "'" + ResolvedRemove {..} -> + putStrLn $ "Remove [" <> getRuleName (name rule) <> "] '" <> original <> "'" -data Action = Action - { from :: FilePath, - to :: FilePath - } +data FsAction + = FsMove {from :: FilePath, to :: FilePath} + | FsCopy {from :: FilePath, to :: FilePath} + | FsRemove {from :: FilePath} deriving stock (Eq, Show, Generic) data ActionResult = Done | Existing + | Missing | IOException IOError deriving stock (Eq, Show, Generic) -type RunResult = [(Action, ActionResult)] +type RunResult = [(FsAction, ActionResult)] -runPlan :: [Move] -> IO RunResult +runPlan :: [ResolvedAction] -> IO RunResult runPlan = fmap catMaybes . run where run = - mapM $ \Move {..} -> - case new of - Nothing -> return Nothing - Just newPath -> do - let action = Action original newPath - existing <- doesFileExist newPath - if existing - then return $ Just (action, Existing) + mapM $ + \case + ResolvedMove {..} -> do + let fsAction = FsMove original new + originalPresent <- doesFileExist original + if not originalPresent + then return $ Just (fsAction, Missing) else do - prepareDirectory newPath - Just . (,) action <$> ((renameFile original newPath $> Done) `catch` (return . IOException)) + newPresent <- doesFileExist new + if newPresent + then return $ Just (fsAction, Existing) + else do + prepareDirectory new + let resillientMove from to = renameFile from to `catch` const @_ @IOError (copyFileWithMetadata from to >> removeFile from) + Just . (,) fsAction <$> ((resillientMove original new $> Done) `catch` (return . IOException)) + ResolvedCopy {..} -> do + let fsAction = FsCopy original new + originalPresent <- doesFileExist original + if not originalPresent + then return $ Just (fsAction, Missing) + else do + newPresent <- doesFileExist new + if newPresent + then return $ Just (fsAction, Existing) + else do + prepareDirectory new + Just . (,) fsAction <$> ((copyFile original new $> Done) `catch` (return . IOException)) + ResolvedRemove {..} -> do + let fsAction = FsRemove original + originalPresent <- doesFileExist original + if not originalPresent + then return $ Just (fsAction, Missing) + else Just . (,) fsAction <$> ((removeFile original $> Done) `catch` (return . IOException)) prepareDirectory = createDirectoryIfMissing True . fst . splitFileName displayResult :: RunResult -> IO () displayResult = - mapM_ $ \(Action {..}, result) -> - case result of - Done -> return () - Existing -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' ALREADY EXISTING" - IOException e -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' IOError (" <> show e <> ")" + mapM_ $ \(action, result) -> + case action of + FsMove {..} -> + case result of + Done -> return () + Existing -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' ALREADY EXISTING" + Missing -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' MISSING" + IOException e -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' IOError (" <> show e <> ")" + FsCopy {..} -> + case result of + Done -> return () + Existing -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' ALREADY EXISTING" + Missing -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' MISSING" + IOException e -> putStrLn $ "'" <> from <> "' -> '" <> to <> "' IOError (" <> show e <> ")" + FsRemove {..} -> + case result of + Done -> return () + Existing -> putStrLn $ "'" <> from <> "' ALREADY EXISTING (BUG)" + Missing -> putStrLn $ "'" <> from <> "' MISSING" + IOException e -> putStrLn $ "'" <> from <> "' IOError (" <> show e <> ")" diff --git a/test/LibrarianSpec.hs b/test/LibrarianSpec.hs --- a/test/LibrarianSpec.hs +++ b/test/LibrarianSpec.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module LibrarianSpec ( main, spec, @@ -5,7 +8,11 @@ where import Control.Monad +import Data.Function (on) +import Data.List (sort) import qualified Data.Map.Strict as Map +import Data.String (IsString (..)) +import Data.Time (addUTCTime, getCurrentTime, nominalDay, secondsToNominalDiffTime) import Librarian import System.Directory import System.EasyFile @@ -19,73 +26,281 @@ spec :: Spec spec = do describe "fetchRulesOn" $ do - it "Empty target directory should be empty" $ - withFiles [] (fetchRulesOn "." rules) - `shouldReturn` mempty - it "Text files only should match only all rule" $ - withFiles ["in/sub/0.txt", "in/1.txt"] (fetchRulesOn "." rules) - `shouldReturn` Map.fromList [("./in/sub/0.txt", rule1All), ("./in/1.txt", rule1All)] - it "Text/images files should match by priority" $ - withFiles ["in/sub/0.jpg", "in/1.txt"] (fetchRulesOn "." rules) - `shouldReturn` Map.fromList [("./in/sub/0.jpg", rule0Jpg), ("./in/1.txt", rule1All)] - describe "planMoves" $ do - it "Images should be moved, texts should have their extension changed" $ - planMoves (Map.fromList [("./in/sub/0.jpg", rule0Jpg), ("./in/1.txt", rule1All)]) - `shouldBe` [ Move "./in/1.txt" (Just "./in/1.TXT") rule1All, - Move "./in/sub/0.jpg" (Just "out/pics/0.jpg") rule0Jpg - ] - it "Non-matching mover should be nothing" $ - planMoves (Map.fromList [("./in/1.png", rule1All)]) - `shouldBe` [Move "./in/1.png" Nothing rule1All] + describe "move" $ do + it "Empty target directory should be empty" $ + withFiles [] (fetchRulesOn "." moveRules) + `shouldReturn` mempty + it "Text files only should match only all rule" $ + withFiles ["in/sub/0.txt", "in/1.txt"] (fetchRulesOn "." moveRules) + `shouldReturn` Map.fromList [("./in/sub/0.txt", [moveRule1Any]), ("./in/1.txt", [moveRule1Any])] + it "Text/images files should match twice" $ + withFiles ["in/sub/0.jpg", "in/1.txt"] (fetchRulesOn "." moveRules) + `shouldReturn` Map.fromList [("./in/sub/0.jpg", [moveRule0Jpg, moveRule1Any]), ("./in/1.txt", [moveRule1Any])] + describe "copy" $ do + it "Empty target directory should be empty" $ + withFiles [] (fetchRulesOn "." copyRules) + `shouldReturn` mempty + it "Text files only should match only all rule" $ + withFiles ["in/sub/0.txt", "in/1.txt"] (fetchRulesOn "." copyRules) + `shouldReturn` Map.fromList [("./in/sub/0.txt", [copyRule1Any]), ("./in/1.txt", [copyRule1Any])] + it "Text/images files should match twice" $ + withFiles ["in/sub/0.jpg", "in/1.txt"] (fetchRulesOn "." copyRules) + `shouldReturn` Map.fromList [("./in/sub/0.jpg", [copyRule0Jpg, copyRule1Any]), ("./in/1.txt", [copyRule1Any])] + describe "remove" $ do + it "Empty target directory should be empty" $ + withFiles [] (fetchRulesOn "." removeRules) + `shouldReturn` mempty + it "Text files only should match only all rule" $ + withFiles ["in/sub/0.txt", "in/1.txt"] (fetchRulesOn "." removeRules) + `shouldReturn` Map.fromList [("./in/sub/0.txt", [removeRule1Any]), ("./in/1.txt", [removeRule1Any])] + it "Text/images files should match twice" $ + withFiles ["in/sub/0.jpg", "in/1.txt"] (fetchRulesOn "." removeRules) + `shouldReturn` Map.fromList [("./in/sub/0.jpg", [removeRule0Jpg, removeRule1Any]), ("./in/1.txt", [removeRule1Any])] + describe "planActions" $ do + describe "move" $ do + it "Images should be moved, texts should have their extension changed" $ + planActions (Map.fromList [("./in/sub/0.jpg", [moveRule0Jpg]), ("./in/1.txt", [moveRule1Any])]) + `shouldBe` [ ResolvedMove "./in/1.txt" "./in/1.TXT" moveRule1Any, + ResolvedMove "./in/sub/0.jpg" "out/pics/0.jpg" moveRule0Jpg + ] + it "Non-matching action should be nothing" $ + planActions (Map.fromList [("./in/1.png", [moveRule1Any])]) + `shouldBe` [] + describe "copy" $ do + it "Images should be copyd, texts should have their extension changed" $ + planActions (Map.fromList [("./in/sub/0.jpg", [copyRule0Jpg]), ("./in/1.txt", [copyRule1Any])]) + `shouldBe` [ ResolvedCopy "./in/1.txt" "./in/1.TXT" copyRule1Any, + ResolvedCopy "./in/sub/0.jpg" "out/pics/0.jpg" copyRule0Jpg + ] + it "Non-matching action should be nothing" $ + planActions (Map.fromList [("./in/1.png", [copyRule1Any])]) + `shouldBe` [] + describe "remove" $ do + it "Images should be removed" $ + planActions (Map.fromList [("./in/sub/0.jpg", [removeRule0Jpg]), ("./in/1.txt", [removeRule1Any])]) + `shouldBe` [ ResolvedRemove "./in/1.txt" removeRule1Any, + ResolvedRemove "./in/sub/0.jpg" removeRule0Jpg + ] + it "Non-matching action should be nothing" $ + planActions (Map.fromList [("./in/1.png", [removeRule1Any])]) + `shouldBe` [] + describe "mixed" $ do + it "Images should be copied and removed, texts should have their extension changed" $ + planActions (Map.fromList [("./in/sub/0.jpg", [copyRule0Jpg, removeRule0Jpg])]) + `shouldBe` [ ResolvedCopy "./in/sub/0.jpg" "out/pics/0.jpg" copyRule0Jpg, + ResolvedRemove "./in/sub/0.jpg" removeRule0Jpg + ] describe "runPlan" $ do - let moveAll = fetchRulesOn "." [overridingRule] >>= runPlan . planMoves - it "Overriding paths should block the second move" $ - withFiles ["in/0.txt", "in/sub/0.txt"] moveAll - `shouldReturn` [ (Action "./in/0.txt" "out/0.txt", Done), - (Action "./in/sub/0.txt" "out/0.txt", Existing) - ] - it "Overriding paths should keep the second file" $ - withFiles ["in/0.txt", "in/sub/0.txt"] (moveAll >> listFiles) - `shouldReturn` ["./out/0.txt", "./in/sub/0.txt"] + describe "move" $ do + let moveAll = fetchRulesOn "." [moveAllTxtRule] >>= runPlan . planActions + it "Overriding paths should block the second move" $ + withFiles ["in/0.txt", "in/sub/0.txt"] moveAll + `shouldReturn` [ (FsMove "./in/0.txt" "out/0.txt", Done), + (FsMove "./in/sub/0.txt" "out/0.txt", Existing) + ] + it "Overriding paths should keep the second file" $ + withFiles ["in/0.txt", "in/sub/0.txt"] (moveAll >> listFiles) + `shouldReturn` ["./in/sub/0.txt", "./out/0.txt"] + describe "copy" $ do + let copyAll = fetchRulesOn "." [copyAllTxtRule] >>= runPlan . planActions + it "Overriding paths should block the second copy" $ + withFiles ["in/0.txt", "in/sub/0.txt"] copyAll + `shouldReturn` [ (FsCopy "./in/0.txt" "out/0.txt", Done), + (FsCopy "./in/sub/0.txt" "out/0.txt", Existing) + ] + it "Overriding paths should keep the second file" $ + withFiles ["in/0.txt", "in/sub/0.txt"] (copyAll >> listFiles) + `shouldReturn` ["./in/0.txt", "./in/sub/0.txt", "./out/0.txt"] + describe "remove" $ do + let removeAll = fetchRulesOn "." [removeAllTxtRule] >>= runPlan . planActions + it "Should keep the non-matching file" $ + withFiles ["in/0.txt", "in/sub/0.txt", "in/0.jpg"] removeAll + `shouldReturn` [ (FsRemove "./in/0.txt", Done), + (FsRemove "./in/sub/0.txt", Done) + ] + it "Should keep the non-matching file" $ + withFiles ["in/0.txt", "in/sub/0.txt", "in/0.jpg"] (removeAll >> listFiles) + `shouldReturn` ["./in/0.jpg"] + describe "mixed" $ do + let mixed = fetchRulesOn "." [copyAllTxtRule, removeAllTxtRule] >>= runPlan . planActions + it "Should copy and delete" $ + withFiles ["in/0.txt"] (mixed >> listFiles) + `shouldReturn` ["./out/0.txt"] + describe "time-based" $ do + let timeBased = fetchRulesOn "." [removeAllMidOldTtxt] >>= runPlan . planActions + it "Should keep older and younger file" $ + withFiles + [ "in/1.txt" {modificationTime = Just $ DaysAgo 1}, + "in/7.txt" {modificationTime = Just $ DaysAgo 7}, + "in/32.txt" {modificationTime = Just $ DaysAgo 32}, + "in/32a.txt" {modificationTime = Just $ DaysAgo 32}, + "in/32b.txt" {modificationTime = Just $ DaysAgo 32}, + "in/101.txt" {modificationTime = Just $ DaysAgo 101} + ] + (timeBased >> listFiles) + `shouldReturn` ["./in/1.txt", "./in/101.txt", "./in/32.txt", "./in/7.txt"] -withFiles :: [FilePath] -> IO a -> IO a +-- * Utils + +data FileSpec = FileSpec + { path :: FilePath, + accessTime :: Maybe TimeSpec, + modificationTime :: Maybe TimeSpec + } + deriving stock (Eq, Show) + +instance IsString FileSpec where + fromString p = + FileSpec {path = p, accessTime = Nothing, modificationTime = Nothing} + +withFiles :: [FileSpec] -> IO a -> IO a withFiles files act = withSystemTempDirectory "librarian-tests" $ \d -> withCurrentDirectory d $ do mapM_ touch files act -touch :: FilePath -> IO () +touch :: FileSpec -> IO () touch target = do - createDirectoryIfMissing True $ fst $ splitFileName target - writeFile target "-" + createDirectoryIfMissing True $ fst $ splitFileName target.path + writeFile target.path "-" + let computeTime = + \case + HoursAgo d -> addUTCTime (secondsToNominalDiffTime $ (-1) * fromInteger d * 60 * 60) <$> getCurrentTime + DaysAgo d -> addUTCTime ((-1) * fromInteger d * nominalDay) <$> getCurrentTime + AbsoluteTime x -> return x + forM_ target.accessTime $ setAccessTime target.path <=< computeTime + forM_ target.modificationTime $ setModificationTime target.path <=< computeTime -rules :: [Rule] -rules = [rule0Jpg, rule1All] +listFiles :: IO [FilePath] +listFiles = glob "./**/*" >>= fmap sort . filterM doesFileExist -rule0Jpg :: Rule -rule0Jpg = +instance Eq Rule where + (==) = (==) `on` show + +instance Eq ResolvedAction where + (==) = (==) `on` show + +-- * Fixtures + +-- ** move + +moveRules :: [Rule] +moveRules = [moveRule0Jpg, moveRule1Any] + +moveRule0Jpg :: Rule +moveRule0Jpg = Rule - { name = "Image files", + { name = "Image files (move)", match = "**/*.jpg", - movers = [Mover "^.*/([^\\/]+)$" "out/pics/\\1"] + grouping = FileGroup, + filtering = AllF, + actions = [Move "^.*/([^\\/]+)$" "out/pics/\\1"] } -rule1All :: Rule -rule1All = +moveRule1Any :: Rule +moveRule1Any = Rule - { name = "All files", + { name = "All files (move)", match = "**/*", - movers = [Mover "pdf$" "PDF", Mover "txt$" "TXT", Mover "txt$" "TxT"] + grouping = FileGroup, + filtering = AllF, + actions = [Move "pdf$" "PDF", Move "txt$" "TXT", Move "txt$" "TxT"] } -overridingRule :: Rule -overridingRule = +moveAllTxtRule :: Rule +moveAllTxtRule = Rule - { name = "Text files", + { name = "Text files (move)", match = "**/*.txt", - movers = [Mover "^.*/([^\\/]+)$" "out/\\1"] + grouping = FileGroup, + filtering = AllF, + actions = [Move "^.*/([^\\/]+)$" "out/\\1"] } -listFiles :: IO [FilePath] -listFiles = glob "./**/*" >>= filterM doesFileExist +-- ** copy + +copyRules :: [Rule] +copyRules = [copyRule0Jpg, copyRule1Any] + +copyRule0Jpg :: Rule +copyRule0Jpg = + Rule + { name = "Image files (copy)", + match = "**/*.jpg", + grouping = FileGroup, + filtering = AllF, + actions = [Copy "^.*/([^\\/]+)$" "out/pics/\\1"] + } + +copyRule1Any :: Rule +copyRule1Any = + Rule + { name = "All files (copy)", + match = "**/*", + grouping = FileGroup, + filtering = AllF, + actions = [Copy "pdf$" "PDF", Copy "txt$" "TXT", Copy "txt$" "TxT"] + } + +copyAllTxtRule :: Rule +copyAllTxtRule = + Rule + { name = "Text files (copy)", + match = "**/*.txt", + grouping = FileGroup, + filtering = AllF, + actions = [Copy "^.*/([^\\/]+)$" "out/\\1"] + } + +-- ** remove + +removeRules :: [Rule] +removeRules = [removeRule0Jpg, removeRule1Any] + +removeRule0Jpg :: Rule +removeRule0Jpg = + Rule + { name = "Image files (remove)", + match = "**/*.jpg", + grouping = FileGroup, + filtering = AllF, + actions = [Remove "^.*/([^\\/]+)$"] + } + +removeRule1Any :: Rule +removeRule1Any = + Rule + { name = "All files (remove)", + match = "**/*", + grouping = FileGroup, + filtering = AllF, + actions = [Remove "pdf$", Remove "txt$", Remove "txt$"] + } + +removeAllTxtRule :: Rule +removeAllTxtRule = + Rule + { name = "Text files (remove)", + match = "**/*.txt", + grouping = FileGroup, + filtering = AllF, + actions = [Remove "^.*/([^\\/]+)$"] + } + +removeAllMidOldTtxt :: Rule +removeAllMidOldTtxt = + Rule + { name = "Purge not-too-old text files", + match = "**/*.txt", + grouping = + Group + { groupSource = SourceDate ModificationTime, + groupBucket = Monthly, + groupSelection = After 0 SortingAsc (SourceDate ModificationTime) + }, + filtering = + LtF (SourceDate ModificationTime) (SourceTime $ DaysAgo 31) + `AndF` GtF (SourceDate ModificationTime) (SourceTime $ DaysAgo 92), + actions = [Remove "^.*/([^\\/]+)$"] + }