diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Henning Thielemann 2014 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/group-by-date.cabal b/group-by-date.cabal new file mode 100644 --- /dev/null +++ b/group-by-date.cabal @@ -0,0 +1,77 @@ +Name: group-by-date +Version: 0.0 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://hub.darcs.net/thielema/group-by-date/ +Category: Console +Synopsis: Shell command for grouping files by dates into folders +Description: + This program is intended for grouping photography images by date + into a hierarchy of date related folders. + . + If you have a folder of photographies, say @photos@, + you may run + . + > group-by-date -r photos + . + The program will emit a Bash script like this one: + . + > mkdir -p 2017/2017-06/2017-06-28 && mv photos/0001.jpeg 2017/2017-06/2017-06-28 + > mkdir -p 2017/2017-06/2017-06-28 && mv photos/0002.jpeg 2017/2017-06/2017-06-28 + > mkdir -p 2017/2017-06/2017-06-28 && mv photos/0003.jpeg 2017/2017-06/2017-06-28 + . + You can inspect the script and if you like it, you can run it: + . + > group-by-date -r photos | bash + . + If you want a different command, say @cp@, you can call + . + > group-by-date --command=cp -r photos + . + Alternatively, you can run the actions immediately, + that is, without a Bash script: + . + > group-by-date --mode=move -r photos + > group-by-date --mode=copy -r photos + . + You can also change the target directory structure + using the @--format@ option. + You can list all options and default values using @--help@. + . + Attention: + Media for photographies is often formatted with FAT. + This may yield trouble with respect to timezones. +Tested-With: GHC==7.8.3 +Cabal-Version: >=1.6 +Build-Type: Simple + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: http://hub.darcs.net/thielema/group-by-date/ + +Source-Repository head + Type: darcs + Location: http://hub.darcs.net/thielema/group-by-date/ + +Executable group-by-date + Build-Depends: + hsshellscript >=3.1.0 && <3.4, + filemanip >=0.3.5 && <0.4, + filepath >=1.3 && <1.4, + -- version for directory needed for getModificationTime returning UTCTime + directory >=1.2 && <1.3, + time >=1.4 && <1.6, + old-locale >=1.0 && <1.1, + unix-compat >=0.3 && <0.5, + explicit-exception >=0.1 && <0.2, + transformers >=0.2 && <0.6, + utility-ht >=0.0.1 && <0.1, + base >=3 && <5 + + GHC-Options: -Wall + Hs-source-dirs: src + Other-Modules: GroupByDate + Main-Is: Main.hs diff --git a/src/GroupByDate.hs b/src/GroupByDate.hs new file mode 100644 --- /dev/null +++ b/src/GroupByDate.hs @@ -0,0 +1,67 @@ +module GroupByDate where + +import qualified System.Directory as Dir +import qualified System.PosixCompat.Files as Files +import qualified System.FilePath as FilePath +import System.FilePath ((), ) +import HsShellScript.Shell (shell_quote, ) + +import qualified Data.Time.Format as Time +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, ) +import System.Locale (defaultTimeLocale, ) + +import Text.Printf (printf, ) + +import Control.Monad (when, ) + + +folderFromStatus :: String -> Files.FileStatus -> FilePath +folderFromStatus fmt = + Time.formatTime defaultTimeLocale fmt . + posixSecondsToUTCTime . realToFrac . + Files.modificationTime + +folderFromPath :: String -> FilePath -> IO FilePath +folderFromPath fmt = + fmap (Time.formatTime defaultTimeLocale fmt) . + Dir.getModificationTime + + +makeDstPath :: FilePath -> FilePath -> FilePath +makeDstPath src dst = dst FilePath.takeFileName src + +commandFromPath :: Bool -> String -> String -> FilePath -> IO () +commandFromPath fullDst cmd fmt src = do + dst <- folderFromPath fmt src + printf "mkdir -p %s && %s %s %s\n" + (shell_quote dst) + cmd + (shell_quote src) + (shell_quote $ + if fullDst then makeDstPath src dst else dst) + +movePath :: String -> FilePath -> IO () +movePath fmt src = do + dst <- folderFromPath fmt src + Dir.createDirectoryIfMissing True dst + Dir.renameFile src (makeDstPath src dst) + +copyPath :: String -> FilePath -> IO () +copyPath fmt src = do + dstDir <- folderFromPath fmt src + Dir.createDirectoryIfMissing True dstDir + let dst = makeDstPath src dstDir + Dir.copyFile src dst + status <- Files.getFileStatus src + Files.setFileTimes dst + (Files.accessTime status) (Files.modificationTime status) + when False $ + -- this could fail, if the owner is 'root' e.g. for data on removeable media + Files.setOwnerAndGroup dst + (Files.fileOwner status) (Files.fileGroup status) + +symLinkPath :: String -> FilePath -> IO () +symLinkPath fmt src = do + dst <- folderFromPath fmt src + Dir.createDirectoryIfMissing True dst + Files.createSymbolicLink src (makeDstPath src dst) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,125 @@ +module Main where + +import qualified GroupByDate + +import qualified System.FilePath.Find as FindFile +import System.FilePath.Find ((==?), ) + +import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, ) +import System.Environment (getArgs, getProgName, ) +import System.Exit (exitWith, ExitCode(..), ) + +import qualified Control.Monad.Exception.Synchronous as Exc +import Control.Monad.Trans.Class (lift, ) +import Control.Monad (liftM, when, ) + +import Data.Foldable (forM_, ) +import Data.List (intercalate, ) + +import Text.Printf (printf, ) + + + +data Flags = + Flags { + optHelp :: Bool, + optRecursive :: Bool, + optFullDst :: Bool, + optFormat :: String, + optCommand :: String, + optMode :: Mode + } + +defaultFlags :: Flags +defaultFlags = + Flags { + optHelp = False, + optRecursive = False, + optFullDst = False, + optFormat = "%_Y/%_Y-%m/%_Y-%m-%d", + optCommand = "mv", + optMode = Script + } + + +data Mode = Script | Move | Copy | SymLink + deriving (Eq, Ord, Bounded, Show, Enum) + +parseMode :: String -> Exc.Exceptional String Mode +parseMode str = + case filter ((str==) . formatMode) [minBound..maxBound] of + mode:_ -> return mode + [] -> Exc.throw $ "unknown mode " ++ show str + +formatMode :: Mode -> String +formatMode op = + case op of + Script -> "script" + Move -> "move" + Copy -> "copy" + SymLink -> "symlink" + + +options :: [OptDescr (Flags -> Exc.Exceptional String Flags)] +options = + Option ['h'] ["help"] + (NoArg (\flags -> return $ flags{optHelp = True})) + "show options" : + Option ['r'] ["recursive"] + (NoArg (\flags -> return $ flags{optRecursive = True})) + "descent recursively into directories" : + Option ['f'] ["format"] + (ReqArg (\str flags -> return $ flags{optFormat = str}) "STRING") + (printf "format string for path, default %s" $ + show $ optFormat defaultFlags) : + Option [] ["mode"] + (ReqArg + (\str flags -> fmap (\mode -> flags{optMode = mode}) $ parseMode str) + "STRING") + (printf "mode (%s), default %s" + (intercalate ", " $ map formatMode [minBound..maxBound]) + (show $ formatMode $ optMode defaultFlags)) : + Option [] ["command"] + (ReqArg (\str flags -> return $ flags{optCommand = str}) "STRING") + (printf "command for file transfer in script, default %s" $ + show $ optCommand defaultFlags) : + [] + + +main :: IO () +main = + Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do + argv <- lift getArgs + let (opts, filesAndDirs, errors) = getOpt RequireOrder options argv + when (not (null errors)) $ Exc.throwT $ concat $ errors + flags <- + Exc.ExceptionalT $ return $ + foldr (flip (>>=)) (return defaultFlags) opts + when (optHelp flags) $ lift $ do + programName <- getProgName + putStrLn + (usageInfo + ("Usage: " ++ programName ++ + " [OPTIONS] FILES-AND-DIRECTORIES ...") + options) + exitWith ExitSuccess + + files <- + if optRecursive flags + then lift $ liftM concat $ + mapM + (FindFile.find FindFile.always + (FindFile.fileType ==? FindFile.RegularFile)) + filesAndDirs + else return filesAndDirs + + let process = + case optMode flags of + Script -> + GroupByDate.commandFromPath + (optFullDst flags) (optCommand flags) (optFormat flags) + Move -> GroupByDate.movePath (optFormat flags) + Copy -> GroupByDate.copyPath (optFormat flags) + SymLink -> GroupByDate.symLinkPath (optFormat flags) + + forM_ files $ lift . process