librarian 0.1.0.0 → 0.1.0.1
raw patch · 8 files changed
+848/−142 lines, 8 filesdep +eitherdep +textdep +timedep ~dhallnew-component:exe:librarian-exe
Dependencies added: either, text, time
Dependency ranges changed: dhall
Files
- README.md +36/−0
- app/Convert.hs +87/−0
- app/DhallTypes.hs +125/−0
- app/Main.hs +45/−16
- changelog.md +6/−0
- librarian.cabal +17/−5
- src/Librarian.hs +270/−74
- test/LibrarianSpec.hs +262/−47
+ README.md view
@@ -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)+```
+ app/Convert.hs view
@@ -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
+ app/DhallTypes.hs view
@@ -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
app/Main.hs view
@@ -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)
+ changelog.md view
@@ -0,0 +1,6 @@+# Librarian++## 0.1.0.1++* @blackheaven+ * Fix cross-devices `Move`
librarian.cabal view
@@ -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
src/Librarian.hs view
@@ -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 <> ")"
test/LibrarianSpec.hs view
@@ -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 "^.*/([^\\/]+)$"]+ }