diff --git a/README b/README --- a/README +++ b/README @@ -12,8 +12,7 @@ and the usually-camera-assigned serial number, often appearing in the filename. -This program is known to work with GHC 6.8.2 on systems where System.Posix -(unix) packages are available. +This program is known to work with GHC 6.8.3 (and probably still 6.8.2) on systems where System.Posix (unix) packages are available. *install* @@ -24,5 +23,3 @@ $ runhaskell Setup.lhs build $ runhaskell Setup.lhs test $ runhaskell Setup.lhs install - -A Debian .deb package is available for this project at its home page: http://ui3.info/d/proj/photoname.html diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,13 +1,5 @@ -- I wonder if changing to record style for the Opts.Flags would make any of the code simpler in Main - - Add support for different camera filename formats, check with the Olympus. -- Rewrite buildNewPath with MaybeT? - see: http://haskell.org/haskellwiki/New_monads/MaybeT - - -features that would be nice: - - First, I think I'd like to see the PARENTDIR argument become a named switch (-d --parent-dir), to better differentiate it from the list of files to be processed. - Second, I'd like to start using a config file (~/.photoname) that will contain things like default parent dir: @@ -29,4 +21,4 @@ - Deal gracefully with unknown dates. This means not just putting pictures into the 0000/0000-00-00 directory, but making sure that the _### serial number part is incremented from the highest one in there. -- Allow additional switch for part of filenames for initials of photographer: _xyz +- Allow additional switch for part of filenames for initials of photographer: _xyz Call this the suffix? (-s --suffix) diff --git a/doc/dev/notes b/doc/dev/notes --- a/doc/dev/notes +++ b/doc/dev/notes @@ -1,7 +1,5 @@ ----- -rearchitecture of Main: - -flags used in: createNewLink, executeCommands, main +Do something with this, better error checking? - Parse arguments - Look at args, cases: diff --git a/doc/hcar-photoname b/doc/hcar-photoname --- a/doc/hcar-photoname +++ b/doc/hcar-photoname @@ -15,6 +15,10 @@ photoname is a command-line utility for renaming/moving photo image files. The new folder location and naming are determined by the EXIF photo shoot date and the usually-camera-assigned serial number, often appearing in the filename. +Between versions 2.0 and 2.1 the software is largely the same on the outside but has undergone extensive changes inside. Most of this involving redesign with monad transformers. + +photoname is on Hackage and can be acquired using darcs or other methods. See the project page below for more. + Further reading diff --git a/photoname.cabal b/photoname.cabal --- a/photoname.cabal +++ b/photoname.cabal @@ -1,5 +1,6 @@ name: photoname -version: 2.0 +cabal-version: >= 1.2 +version: 2.1 build-type: Simple license: BSD3 license-file: LICENSE @@ -13,10 +14,11 @@ Command-line utility for renaming/moving photo image files based on EXIF tags. Written in Haskell. category: Unclassified -tested-with: GHC==6.8.2 +tested-with: GHC>=6.8.2 -executable: photoname -build-depends: base, exif, filepath, mtl, old-locale, parsec, time, unix -main-is: Main.hs -ghc-options: -Wall -hs-source-dirs: src +executable photoname + main-is: photoname.hs + build-depends: base, exif, filepath, mtl, old-locale, parsec, + time, unix + ghc-options: -Wall + hs-source-dirs: src diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,179 +0,0 @@ --- Copyright: 2007, 2008 Dino Morelli --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -module Main - where - -import Control.Monad.Reader -import Control.Monad.Writer -import qualified Graphics.Exif as Exif -import Photoname.Date -import qualified Photoname.Opts as Opts -import Photoname.Serial ( getSerial ) -import System.Environment ( getArgs ) -import System.FilePath -import System.Posix - - -modeDir :: FileMode -modeDir = ownerModes `unionFileModes` - groupReadMode `unionFileModes` - groupExecuteMode - - -{- Given a list of lists, make a new list where each sublist element - consists of the accumulation of all parts that came before it. - Like this: - before: [[1], [2], [3], [4], [5]] - after : [[1], [1,2], [1,2,3], [1,2,3,4], [1,2,3,4,5]] - - Many thanks to Betty Diegel for help with this algorithm. --} -listAcc :: [[a]] -> [[a]] -listAcc [] = [[]] -listAcc (x:xs) = listAcc' x xs - where - listAcc' l (y:ys) = [l] ++ listAcc' (l ++ y) ys - listAcc' l [] = [l] - - -{- Execute a sequence of m (Maybe a) actions until the first non-Nothing - evaluation, eval to that. - - Thanks to sjanssen et al on #haskell - - XXX Can this be genericized to be :: (Monad m, Monad n) => - [m (n a)] -> m (n a) - XXX Put this in a more common module. --} -firstSuccess :: Monad m => [m (Maybe a)] -> m (Maybe a) -firstSuccess = foldr f (return Nothing) - where - f :: Monad t => t (Maybe m1) -> t (Maybe m1) -> t (Maybe m1) - f m ms = do -- m in here, NOT Maybe - x <- m - case x of - Just _ -> return x - Nothing -> ms - - -{- Get shoot date from the exif information. There are several tags - potentially containing dates. Try them in a specific order until we - find one that has data. --} -getDate :: Exif.Exif -> IO (Maybe String) -getDate exif = - firstSuccess $ map (Exif.getTag exif) - ["DateTimeDigitized", "DateTimeOriginal", "DateTime"] - - -{- Take a file path to a JPEG file and use EXIF information available to - move the file to a new location below the given basedir. --} -createNewLink :: FilePath -> FilePath -> Ph () -createNewLink newDir oldPath = do - flags <- ask - e <- liftIO $ buildNewPath newDir oldPath - case e of - Left err -> tell [err] - Right newPath -> do - -- Check for existance of the target file - exists <- liftIO $ fileExist newPath - if exists - then tell - ["** " ++ oldPath ++ " -> " ++ newPath ++ " exists!"] - else do - -- Display what will be done - unless (Opts.Quiet `elem` flags) $ - tell [(oldPath ++ " -> " ++ newPath)] - - unless (Opts.NoAction `elem` flags) $ do - -- Make the target dir - liftIO $ makeDirectory $ takeDirectory newPath - - -- Make the new hard link - liftIO $ createLink oldPath newPath - - -- If user has specified, remove the original link - when (Opts.Move `elem` flags) $ - liftIO $ removeLink oldPath - - -{- Ensuring that a directory with subs exists turned out to be a painful - process involving making each parent dir piece by piece but not trying - to make anything that's already there. --} -makeDirectory :: FilePath -> IO () -makeDirectory d = - let makeOneDir dir = do - exists <- fileExist dir - unless exists $ createDirectory dir modeDir - in mapM_ makeOneDir $ listAcc $ splitPath d - - -{- Given a path to a file with EXIF data, construct a new path based on the - date and some serial number info we can parse out of the filename. - This function got complicated, there are several ways this can fail. --} -buildNewPath :: FilePath -> FilePath -> IO (Either String FilePath) -buildNewPath newDir oldPath = do - exif <- Exif.fromFile oldPath - maybeDs <- getDate exif - case maybeDs of - Just ds -> do - let date = readDate ds - let maybeSerial = getSerial oldPath - case maybeSerial of - Just serial -> do - let year = formatYear date - let day = formatDay date - let prefix = formatPrefix date - return $ Right $ newDir year day - (prefix ++ "_" ++ serial) <.> "jpg" - Nothing -> return $ Left $ "File " ++ oldPath ++ " has no serial." - Nothing -> return $ Left $ "File " ++ oldPath ++ " has no EXIF date." - - --- Figure out and execute what the user wants based on the supplied args. -executeCommands :: [String] -> Ph () - --- User gave no files at all. Display help -executeCommands [] = tell [Opts.usageText] - --- Normal program operation, process the files with the args. -executeCommands (dir:filePaths) = do - flags <- ask - - -- Get rid of anything not a regular file from the list of paths - actualPaths <- liftIO $ filterM - (\p -> getFileStatus p >>= return . isRegularFile) filePaths - - -- Notify user of the switches that will be in effect. - when (Opts.NoAction `elem` flags) $ - tell ["No-action mode, nothing will be changed."] - - when (Opts.Move `elem` flags) $ - tell ["Removing original links after new links are in place."] - - -- Do the link manipulations. - mapM_ (createNewLink dir) actualPaths - - -type Ph a = ReaderT [Opts.Flag] (WriterT [String] IO) a - -runMain :: [Opts.Flag] -> Ph a -> IO (a, [String]) -runMain env exec = runWriterT $ runReaderT exec env - -main :: IO () -main = do - -- Parse the arguments - (flags, paths) <- getArgs >>= Opts.parseOpts - - -- Do the photo naming procedure - (rval, messages) <- runMain flags $ executeCommands paths - - -- Display collected output log - putStrLn $ unlines messages - - return rval diff --git a/src/Photoname/Opts.hs b/src/Photoname/Opts.hs --- a/src/Photoname/Opts.hs +++ b/src/Photoname/Opts.hs @@ -3,8 +3,7 @@ -- Author: Dino Morelli module Photoname.Opts - ( Flag (..) - , Opts + ( Options (..) , parseOpts, usageText ) where @@ -12,37 +11,45 @@ import System.Console.GetOpt -data Flag - = NoAction - | Quiet - | Move - | Help - deriving Eq +data Options = Options + { optNoAction :: Bool + , optQuiet :: Bool + , optMove :: Bool + , optHelp :: Bool + } --- A convenience type representing all flags and all non-flag strings --- that came in from outside -type Opts = ([Flag], [String]) +defaultOptions :: Options +defaultOptions = Options + { optNoAction = False + , optQuiet = False + , optMove = False + , optHelp = False + } -options :: [OptDescr Flag] +options :: [OptDescr (Options -> Options)] options = - [ Option ['n'] ["no-action"] (NoArg NoAction) - "Display what would be done, but do nothing" - , Option ['q'] ["quiet"] (NoArg Quiet) - "Suppress normal output of what's being done" - , Option [] ["move"] (NoArg Move) - "Move the files, don't just hard-link to the new locations" - , Option ['h'] ["help"] (NoArg Help) - "This help text" + [ Option ['n'] ["no-action"] + (NoArg (\opts -> opts { optNoAction = True } )) + "Display what would be done, but do nothing" + , Option ['q'] ["quiet"] + (NoArg (\opts -> opts { optQuiet = True } )) + "Suppress normal output of what's being done" + , Option [] ["move"] + (NoArg (\opts -> opts { optMove = True } )) + "Move the files, don't just hard-link to the new locations" + , Option ['h'] ["help"] + (NoArg (\opts -> opts { optHelp = True } )) + "This help text" ] -parseOpts :: [String] -> IO Opts +parseOpts :: [String] -> IO (Options, [String]) parseOpts argv = case getOpt Permute options argv of - (o,n,[] ) -> return (o,n) - (_,_,errs) -> ioError (userError (concat errs ++ usageText)) + (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) + (_,_,errs) -> ioError $ userError (concat errs ++ usageText) usageText :: String @@ -55,23 +62,22 @@ , "Options:" ] footer = init $ unlines - [ "This software is for renaming and storing your digital photos. It will extract" - , "shoot date from the EXIF data in the image file and use that along with the" - , "usually-camera-assigned serial number to build a meaningful filename." + [ "This software is for renaming and storing your digital photos. It will extract shoot date from the EXIF data in the image file and use that along with the usually-camera-assigned serial number to build a meaningful filename." , "" - , "You get a subdirectory hierarchy consisting of directories for the years," - , "then subdirs within those for the day photos were shot. These day dirs" - , "contain the image files, renamed as follows:" + , "You get a subdirectory hierarchy consisting of directories for the years, then subdirs within those for the day photos were shot. These day dirs contain the image files, renamed as follows:" , "" , "A photo shot on 2002-May-02 with a Canon camera:" , " img_1790.jpg -> /2002/2002-05-02/20020502_790.jpg" , "" - , "The is the one given on the command-line to this utility, and" - , "represents the top-level of where you're storing photos." + , "The code is basically looking for three digits before the file extension to use as a 'serial' number for the day's photos. This is a seemingly common occurrance with cameras that we can pick numbers off the end of the filename, or at least I hope that's the case. Examples of the two that I have:" , "" - , "Note that the default behavior of this software is to create hard links to" - , "the new paths and leave the original links as they were. You can use the" - , "--move switch to blow away the original location, leaving only the new." + , " vvv (use these digits)" + , " Panasonic: P###0###.jpg" + , " Canon: img_####.jpg" + , " ^^^" + , "The is the one given on the command-line to this utility, and represents the top-level of where you're storing photos." , "" - , "Version 2.0 2008-Mar-04 Dino Morelli " + , "Note that the default behavior of this software is to create hard links to the new paths and leave the original links as they were. You can use the --move switch to blow away the original location, leaving only the new." + , "" + , "Version 2.1 2008-Oct-10 Dino Morelli " ] diff --git a/src/Photoname/Serial.hs b/src/Photoname/Serial.hs --- a/src/Photoname/Serial.hs +++ b/src/Photoname/Serial.hs @@ -2,16 +2,19 @@ -- License: BSD3 (see LICENSE) -- Author: Dino Morelli -module Photoname.Serial ( - getSerial -) +{-# LANGUAGE FlexibleContexts #-} + +module Photoname.Serial + ( getSerial + ) where ---import Debug.Trace +import Control.Monad.Error import Text.ParserCombinators.Parsec --- Combinator similar to manyTill, but evaluates to end instead of p +{- Combinator similar to manyTill, but evaluates to end instead of p +-} skipTill :: GenParser tok st t1 -> GenParser tok st t -> GenParser tok st t skipTill p end = scan where @@ -30,13 +33,11 @@ return serial -- Return those 3 digits --- Evaluates one or more parsers trying to find the serial number in the --- supplied path. Transforms the result from Either to Maybe -getSerial :: FilePath -> Maybe String -getSerial s = - case (parse parser "" s) of - Left _ -> Nothing - --Left err -> trace (show err) Nothing - Right x -> Just x - where - parser = serialNum +{- Evaluates one or more parsers trying to find the serial number in the + supplied path. Transforms the result from Either to Maybe +-} +getSerial :: (MonadError String m) => String -> m String +getSerial path = + case (parse serialNum "" path) of + Left _ -> throwError $ "File " ++ path ++ " has no serial" + Right serial -> return serial diff --git a/src/photoname.hs b/src/photoname.hs new file mode 100644 --- /dev/null +++ b/src/photoname.hs @@ -0,0 +1,166 @@ +-- Copyright: 2007, 2008 Dino Morelli +-- License: BSD3 (see LICENSE) +-- Author: Dino Morelli + +{-# LANGUAGE FlexibleContexts #-} + +import Control.Monad.Error +import Control.Monad.Reader +import Graphics.Exif ( fromFile, getTag ) +import System.Environment ( getArgs ) +import System.FilePath +import System.Posix + +import Photoname.Date +import Photoname.Opts ( Options (..) , parseOpts, usageText ) +import Photoname.Serial ( getSerial ) + + +type Ph a = ReaderT Options IO a + + +runRename :: Options -> Ph a -> IO a +runRename env action = runReaderT action env + + +modeDir :: FileMode +modeDir = ownerModes `unionFileModes` + groupReadMode `unionFileModes` + groupExecuteMode + + +{- Get shoot date from the exif information. There are several tags + potentially containing dates. Try them in a specific order until we + find one that has data. +-} +getDate :: (MonadError String m, MonadIO m) => FilePath -> m String +getDate path = do + exif <- liftIO $ fromFile path + + -- This foldl gets us the first IO (Maybe String) that's not Nothing + maybeDate <- liftIO $ foldl (liftM2 mplus) (return Nothing) $ + map (getTag exif) + ["DateTimeDigitized", "DateTimeOriginal", "DateTime"] + + case maybeDate of + Just d -> return d + Nothing -> throwError $ "File " ++ path ++ " has no EXIF date" + + +{- Take a file path to a JPEG file and use EXIF information available to + move the file to a new location below the given basedir. +-} +createNewLink :: FilePath -> FilePath -> Ph () +createNewLink newDir oldPath = do + opts <- ask + result <- liftIO $ runErrorT $ do + newPath <- buildNewPath newDir oldPath + + -- Check for existance of the target file + exists <- liftIO $ fileExist newPath + when exists $ throwError $ + "** " ++ oldPath ++ " -> " ++ newPath ++ " exists!" + + -- Display what will be done + unless (optQuiet opts) $ + liftIO $ putStrLn $ oldPath ++ " -> " ++ newPath + + unless (optNoAction opts) $ do + -- Make the target dir + liftIO $ makeDirectory $ takeDirectory newPath + + -- Make the new hard link + liftIO $ createLink oldPath newPath + + -- If user has specified, remove the original link + when (optMove opts) $ + liftIO $ removeLink oldPath + + return () + + case result of + Left errMsg -> liftIO $ putStrLn errMsg + Right _ -> return () + + +{- Given a list of lists, make a new list where each sublist element + consists of the accumulation of all parts that came before it. + Like this: + before: [[1], [2], [3], [4], [5]] + after : [[1], [1,2], [1,2,3], [1,2,3,4], [1,2,3,4,5]] + + Many thanks to Betty Diegel for help with this algorithm. + + FIXME Try to rewrite this with a scan or something +-} +listAcc :: [[a]] -> [[a]] +listAcc [] = [[]] +listAcc (x:xs) = listAcc' x xs + where + listAcc' l (y:ys) = [l] ++ listAcc' (l ++ y) ys + listAcc' l [] = [l] + + +{- Ensuring that a directory with subs exists turned out to be a painful + process involving making each parent dir piece by piece but not trying + to make anything that's already there. +-} +makeDirectory :: FilePath -> IO () +makeDirectory d = + let makeOneDir dir = do + exists <- fileExist dir + unless exists $ createDirectory dir modeDir + in mapM_ makeOneDir $ listAcc $ splitPath d + + +{- Given a path to a file with EXIF data, construct a new path based on the + date and some serial number info we can parse out of the filename. +-} +buildNewPath :: (MonadError String m, MonadIO m) => + FilePath -> FilePath -> m FilePath +buildNewPath newDir oldPath = do + dateString <- getDate oldPath + serial <- getSerial oldPath + let date = readDate dateString + let year = formatYear date + let day = formatDay date + let prefix = formatPrefix date + return (newDir year day + (prefix ++ "_" ++ serial) <.> "jpg") + + +-- Figure out and execute what the user wants based on the supplied args. +executeCommands :: [String] -> Ph () + +-- User gave no files at all. Display help +executeCommands [] = liftIO $ putStrLn usageText + +-- Normal program operation, process the files with the args. +executeCommands (dir:filePaths) = do + opts <- ask + + -- Get rid of anything not a regular file from the list of paths + actualPaths <- liftIO $ filterM + (\p -> getFileStatus p >>= return . isRegularFile) filePaths + + -- Notify user of the switches that will be in effect. + when (optNoAction opts) $ + liftIO $ putStrLn "No-action mode, nothing will be changed." + + when (optMove opts) $ + liftIO $ putStrLn + "Removing original links after new links are in place." + + -- Do the link manipulations. + mapM_ (createNewLink dir) actualPaths + + +main :: IO () +main = do + -- Parse the arguments + (opts, paths) <- getArgs >>= parseOpts + + -- Do the photo naming procedure + runRename opts $ executeCommands paths + + -- Perhaps we should get an ExitCode back from all this above? diff --git a/testsuite/TestLink.hs b/testsuite/TestLink.hs --- a/testsuite/TestLink.hs +++ b/testsuite/TestLink.hs @@ -159,7 +159,7 @@ -- Test output to stdout assertBool "no EXIF: correct output" - (output =~ "File testsuite/resources/noExif.jpg has no EXIF date." + (output =~ "File testsuite/resources/noExif.jpg has no EXIF date" :: Bool) @@ -172,7 +172,7 @@ -- Test output to stdout assertBool "no serial in filename: correct output" - (output =~ "File testsuite/resources/noSerial.jpg has no serial." + (output =~ "File testsuite/resources/noSerial.jpg has no serial" :: Bool)