group-by-date (empty) → 0.0
raw patch · 5 files changed
+299/−0 lines, 5 filesdep +basedep +directorydep +explicit-exceptionsetup-changed
Dependencies added: base, directory, explicit-exception, filemanip, filepath, hsshellscript, old-locale, time, transformers, unix-compat, utility-ht
Files
- LICENSE +27/−0
- Setup.lhs +3/−0
- group-by-date.cabal +77/−0
- src/GroupByDate.hs +67/−0
- src/Main.hs +125/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ group-by-date.cabal view
@@ -0,0 +1,77 @@+Name: group-by-date+Version: 0.0+License: BSD3+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+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
+ src/GroupByDate.hs view
@@ -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)
+ src/Main.hs view
@@ -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