librarian (empty) → 0.1.0.0
raw patch · 6 files changed
+418/−0 lines, 6 filesdep +Globdep +basedep +containers
Dependencies added: Glob, base, containers, dhall, directory, easy-file, hspec, hspec-core, hspec-discover, librarian, optparse-applicative, pretty-show, regexpr, temporary
Files
- LICENSE +15/−0
- app/Main.hs +33/−0
- librarian.cabal +132/−0
- src/Librarian.hs +146/−0
- test/LibrarianSpec.hs +91/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,15 @@+ISC License++Copyright (c) 2022 Gautier DI FOLCO++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,33 @@+module Main where++import qualified Dhall as Dhall+import Librarian+import Options.Applicative as Options++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"++parseArgs :: IO Args+parseArgs =+ execParser $+ info (argsParser <**> helper) (fullDesc <> header "Librarian: moving files, your rules!")+ where+ argsParser :: Parser Args+ argsParser =+ Args+ <$> strOption (long "rules" <> short 'r' <> metavar "FILE_PATH" <> help "Rules file (.dhall)")++newtype Args = Args {rulesFile :: FilePath}+ deriving stock (Eq, Ord, Show)
+ librarian.cabal view
@@ -0,0 +1,132 @@+cabal-version: 3.0+name: librarian+version: 0.1.0.0+author: Gautier DI FOLCO+maintainer: gautier.difolco@gmail.com+category: Data+build-type: Simple+license: ISC+license-file: LICENSE+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++library+ default-language: Haskell2010+ build-depends:+ base == 4.*+ , containers+ , dhall+ , directory+ , easy-file+ , Glob+ , pretty-show+ , regexpr+ hs-source-dirs: src+ exposed-modules:+ Librarian+ other-modules:+ Paths_librarian+ autogen-modules:+ Paths_librarian+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedLists+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite librarian-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ LibrarianSpec+ Paths_librarian+ autogen-modules:+ Paths_librarian+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedLists+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base+ , librarian+ , containers+ , directory+ , easy-file+ , Glob+ , hspec+ , hspec-core+ , hspec-discover+ , temporary+ default-language: Haskell2010++executable librarian+ -- type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: app+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedLists+ OverloadedRecordDot+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base+ , librarian+ , dhall+ , optparse-applicative+ default-language: Haskell2010
+ src/Librarian.hs view
@@ -0,0 +1,146 @@+module Librarian+ ( Rule (..),+ RuleName (..),++ -- * Collecting+ Matcher (..),+ Mover (..),+ CollectedFiles,+ fetchRulesOn,++ -- * Planning+ Move (..),+ planMoves,+ displayPlan,++ -- * Runner+ Action (..),+ ActionResult (..),+ RunResult,+ runPlan,+ displayResult,+ )+where++import Control.Exception (catch)+import Control.Monad+import Data.Function (on)+import Data.Functor (($>))+import Data.List (find, nubBy, sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)+import Data.String (IsString)+import Dhall (FromDhall)+import GHC.Generics (Generic)+import System.Directory (createDirectoryIfMissing, doesFileExist, 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]+ }+ deriving stock (Eq, Show, Generic)++instance FromDhall Rule++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+ }+ deriving stock (Eq, Show, Generic)++instance FromDhall Mover++type CollectedFiles = Map.Map FilePath 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+ files <- mapM (filterM doesFileExist) matches+ return $ Map.unions $ map Map.fromList $ zipWith distributeRule files rules++data Move = Move+ { original :: FilePath,+ new :: Maybe FilePath,+ rule :: Rule+ }+ deriving stock (Eq, Show, Generic)++planMoves :: CollectedFiles -> [Move]+planMoves = map (uncurry planMove) . 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)++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++data Action = Action+ { from :: FilePath,+ to :: FilePath+ }+ deriving stock (Eq, Show, Generic)++data ActionResult+ = Done+ | Existing+ | IOException IOError+ deriving stock (Eq, Show, Generic)++type RunResult = [(Action, ActionResult)]++runPlan :: [Move] -> 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)+ else do+ prepareDirectory newPath+ Just . (,) action <$> ((renameFile original newPath $> 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 <> ")"
+ test/LibrarianSpec.hs view
@@ -0,0 +1,91 @@+module LibrarianSpec+ ( main,+ spec,+ )+where++import Control.Monad+import qualified Data.Map.Strict as Map+import Librarian+import System.Directory+import System.EasyFile+import System.FilePath.Glob+import System.IO.Temp+import Test.Hspec++main :: IO ()+main = hspec spec++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 "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"]++withFiles :: [FilePath] -> IO a -> IO a+withFiles files act =+ withSystemTempDirectory "librarian-tests" $ \d ->+ withCurrentDirectory d $ do+ mapM_ touch files+ act++touch :: FilePath -> IO ()+touch target = do+ createDirectoryIfMissing True $ fst $ splitFileName target+ writeFile target "-"++rules :: [Rule]+rules = [rule0Jpg, rule1All]++rule0Jpg :: Rule+rule0Jpg =+ Rule+ { name = "Image files",+ match = "**/*.jpg",+ movers = [Mover "^.*/([^\\/]+)$" "out/pics/\\1"]+ }++rule1All :: Rule+rule1All =+ Rule+ { name = "All files",+ match = "**/*",+ movers = [Mover "pdf$" "PDF", Mover "txt$" "TXT", Mover "txt$" "TxT"]+ }++overridingRule :: Rule+overridingRule =+ Rule+ { name = "Text files",+ match = "**/*.txt",+ movers = [Mover "^.*/([^\\/]+)$" "out/\\1"]+ }++listFiles :: IO [FilePath]+listFiles = glob "./**/*" >>= filterM doesFileExist
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}