diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,5 @@ -# Vim swap files -*.sw? - # Stack uses this directory as scratch space. .stack-work/ -# Stack generates the Cabal file from `package.yaml` through hpack. -/*.cabal +# generated by hasktags +tags diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2007-2021, Dino Morelli +Copyright (c) 2007, Dino Morelli Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,23 @@ +5.2 (2024-08-10) + + * Add an option to specify date format string + * Implemented various hlint suggestions + * Added switch to explicitly specify a file extension + * Switch from newtype-generics to OverloadedRecordDot + * Moved Stackage resolver up to lts-21.25 + * Removed end-year in LICENSE and cabal files + * Fixed incorrect types in comments in Photoname.Date + * Removed whitespace around import parens + * Switched from hpack to Cabal library v2.2 + * Now using original file extension when renaming + * Overhauled logging/output in various ways + * Logging shell command failure with ERROR priority + * New get date with exiv2 code now working + * Removed vim swap files from .gitignore + * Added tags file to .gitignore + * Logging now shows Priority at -v3 (DEBUG) level + + 5.1 (2022-01-11) * Added new number-of-links filtering feature diff --git a/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -1,77 +0,0 @@ -name: photoname -version: '5.1' -license: ISC -copyright: 2007-2021 Dino Morelli -author: Dino Morelli -maintainer: Dino Morelli -stability: stable -homepage: http://hub.darcs.net/dino/photoname -synopsis: Rename photo image files based on EXIF shoot date -description: Command-line utility for renaming/moving photo image files based on EXIF tags. -category: Application, Console -tested-with: GHC >= 8.2.2 - -extra-source-files: -- changelog.md -- doc/hcar-photoname.tex -- .gitignore -- hsinstall/share/applications/photoname.desktop -- hsinstall/share/icons/hicolor/scalable/apps/photoname.svg -- package.yaml -- README.md -- stack.yaml -- stack.yaml.lock -- util/resources/test/* - -github: dino-/photoname - -ghc-options: -- -fwarn-tabs -- -Wall -- -Wcompat -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wredundant-constraints - -dependencies: -- base >= 4.5 && < 5.0 -- directory -- filepath -- unix - -library: - source-dirs: src/lib - dependencies: - - containers - - hsexif - - hslogger - - mtl - - newtype-generics - - parsec - - process - - time - -executables: - photoname: - source-dirs: src/app - main: photoname.hs - dependencies: - - ansi-wl-pprint - - heredoc - - hslogger - - newtype-generics - - optparse-applicative - - photoname - -tests: - photoname-tests: - source-dirs: src/tests - main: runtests.hs - dependencies: - - photoname - - process - - regex-posix - - time - - tasty - - tasty-hunit - - tasty-quickcheck diff --git a/photoname.cabal b/photoname.cabal --- a/photoname.cabal +++ b/photoname.cabal @@ -1,113 +1,134 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.4. --- --- see: https://github.com/sol/hpack +cabal-version: 2.2 -name: photoname -version: 5.1 -synopsis: Rename photo image files based on EXIF shoot date -description: Command-line utility for renaming/moving photo image files based on EXIF tags. -category: Application, Console -stability: stable -homepage: http://hub.darcs.net/dino/photoname -bug-reports: https://github.com/dino-/photoname/issues -author: Dino Morelli -maintainer: Dino Morelli -copyright: 2007-2021 Dino Morelli -license: ISC -license-file: LICENSE -build-type: Simple -tested-with: - GHC >= 8.2.2 +name: photoname +version: 5.2 +synopsis: Rename photo image files based on EXIF shoot date +description: Command-line utility for renaming/moving photo image files based + on EXIF tags. +category: Application, Console +stability: stable +homepage: https://github.com/dino-/photoname +bug-reports: https://github.com/dino-/photoname/issues +author: Dino Morelli +maintainer: Dino Morelli +copyright: 2007 Dino Morelli +license: ISC +license-file: LICENSE +build-type: Simple extra-source-files: - changelog.md - doc/hcar-photoname.tex - .gitignore - hsinstall/share/applications/photoname.desktop - hsinstall/share/icons/hicolor/scalable/apps/photoname.svg - package.yaml - README.md - stack.yaml - stack.yaml.lock - util/resources/test/dateTime.jpg - util/resources/test/dateTimeDigitized.jpg - util/resources/test/dateTimeOriginal.jpg - util/resources/test/foobar-2021-10-04-17-29-49-942.jpg - util/resources/test/noDate.jpg - util/resources/test/noExif.jpg - util/resources/test/notAnImage.txt - util/resources/test/test.conf + doc/hcar-photoname.tex + .gitignore + hsinstall/share/applications/photoname.desktop + hsinstall/share/icons/hicolor/scalable/apps/photoname.svg + README.md + stack.yaml + stack.yaml.lock + util/resources/test/dateTime.jpg + util/resources/test/dateTime.webp + util/resources/test/dateTimeDigitized.jpg + util/resources/test/dateTimeOriginal.jpg + util/resources/test/foobar-2021-10-04-17-29-49-942.jpg + util/resources/test/noDate.jpg + util/resources/test/noExif.jpg + util/resources/test/notAnImage.txt + util/resources/test/test.conf +extra-doc-files: + changelog.md source-repository head type: git location: https://github.com/dino-/photoname +common lang + default-language: Haskell2010 + default-extensions: + BangPatterns + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + EmptyCase + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + ScopedTypeVariables + StandaloneDeriving + TupleSections + ghc-options: + -fwarn-tabs + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + build-depends: + directory + , filepath + , unix + library + import: lang exposed-modules: - Photoname.Common - Photoname.CopyLink - Photoname.Date - Photoname.Exif - Photoname.Exiv2 - Photoname.Links - Photoname.Log + Photoname.Common + Photoname.CopyLink + Photoname.Date + Photoname.Exif + Photoname.Exiv2 + Photoname.Links + Photoname.Log other-modules: - Paths_photoname + Paths_photoname + autogen-modules: + Paths_photoname hs-source-dirs: - src/lib - ghc-options: -fwarn-tabs -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + src/lib build-depends: base >=4.5 && <5.0 , containers - , directory - , filepath , hsexif , hslogger , mtl - , newtype-generics , parsec , process , time - , unix - default-language: Haskell2010 executable photoname + import: lang main-is: photoname.hs other-modules: - Photoname.Opts - Paths_photoname + Photoname.Opts + Paths_photoname + autogen-modules: + Paths_photoname hs-source-dirs: src/app - ghc-options: -fwarn-tabs -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: ansi-wl-pprint , base >=4.5 && <5.0 - , directory - , filepath , heredoc , hslogger - , newtype-generics , optparse-applicative , photoname - , unix - default-language: Haskell2010 test-suite photoname-tests + import: lang type: exitcode-stdio-1.0 main-is: runtests.hs other-modules: - Photoname.Test.EndToEnd.Link - Photoname.Test.EndToEnd.Util - Photoname.Test.Unit.Date - Paths_photoname + Photoname.Test.EndToEnd.Link + Photoname.Test.EndToEnd.Util + Photoname.Test.Unit.Date hs-source-dirs: - src/tests - ghc-options: -fwarn-tabs -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + src/tests build-depends: base >=4.5 && <5.0 - , directory - , filepath , photoname , process , regex-posix @@ -115,5 +136,3 @@ , tasty-hunit , tasty-quickcheck , time - , unix - default-language: Haskell2010 diff --git a/src/app/Photoname/Opts.hs b/src/app/Photoname/Opts.hs --- a/src/app/Photoname/Opts.hs +++ b/src/app/Photoname/Opts.hs @@ -5,22 +5,23 @@ ) where -import Data.Version ( showVersion ) +import Data.Version (showVersion) import Options.Applicative -import Paths_photoname ( version ) -import System.Directory ( doesFileExist ) -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure ) -import System.IO ( hPutStrLn, stderr ) -import System.Log ( Priority (INFO) ) -import Text.Heredoc ( here ) -import Text.PrettyPrint.ANSI.Leijen ( string ) -import Text.Printf ( printf ) +import Paths_photoname (version) +import System.Directory (doesFileExist) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import System.Log (Priority (INFO)) +import Text.Heredoc (here) +import Text.PrettyPrint.ANSI.Leijen (string) +import Text.Printf (printf) import Photoname.Common ( Artist (..) , ConfigPath (..) , CopySwitch (..) + , Extension (Extension, UseExistingExtension) , Links (Exactly, NoLimit) , MoveSwitch (..) , NoActionSwitch (..) @@ -30,8 +31,10 @@ , Prefix (..) , Suffix (..) , Verbosity (Verbose) + , defaultDateTimeFormat , readVerbosity ) +import Photoname.Date (formatDateTime, mkDateFormatter) parser :: Parser Options @@ -61,6 +64,21 @@ <> help "No subdirectory hierarchy. Just do DIR/NEWFILE" ) ) + <*> option (Extension <$> str) + ( long "extension" + <> short 'e' + <> metavar "EXT" + <> help "Extension to use for new image file names. Default: Keep existing extension" + <> value UseExistingExtension + ) + <*> option (mkDateFormatter <$> str) + ( long "date-formatter" + <> short 'f' + <> metavar "STR" + <> help (printf "Format string for date/time in the new filenames. Default \"%s\" See DATE FORMATTER" + defaultDateTimeFormat) + <> value formatDateTime + ) <*> option (Exactly <$> auto) ( long "links" <> short 'l' @@ -145,10 +163,10 @@ -- Parse command-line args first to get -c cliOpts <- parseOpts' =<< getArgs - case optConfig cliOpts of + case config cliOpts of Just configPath -> do confArgs <- loadConfig configPath - parseOpts' $ confArgs <> optPaths cliOpts + parseOpts' $ confArgs <> paths cliOpts Nothing -> pure cliOpts @@ -166,7 +184,7 @@ footer' :: InfoMod a -footer' = footerDoc . Just . string $ printf content (showVersion version) +footer' = footerDoc . Just . string $ printf content defaultDateTimeFormat (showVersion version) where content = [here|OVERVIEW This software is for renaming and storing your digital photos. It will attempt to construct a meaningful filename based on the EXIF shoot date in the file or possibly date/time info in the old filename, and optionally some other information. @@ -196,6 +214,13 @@ /20020502-132307.jpg Default behavior is to create hard links to the new paths and leave the original links as they were. You can use the --move switch to remove the original links. You can also use the --copy switch to make a copy instead of hard linking. Also, copying will be attempted if the hard linking fails, for instance if you're naming across different filesystems. + +DATE FORMATTER + +The default date format string is "%s" which yields strings like "yyyymmdd-HHMMSS" +Another example: "%%Y-%%m-%%dt%%H%%M_img" -> "yyyy-mm-ddtHHMM_img" + +Any valid date format string is allowed for the -f|--date-formatter option. Please see the API documentation for help on format strings: https://downloads.haskell.org/ghc/latest/docs/libraries/time-1.12.2-dfcf/Data-Time-Format.html ARTIST diff --git a/src/app/photoname.hs b/src/app/photoname.hs --- a/src/app/photoname.hs +++ b/src/app/photoname.hs @@ -1,33 +1,35 @@ -import Control.Monad ( filterM, forM_, when ) -import Control.Newtype.Generics ( op ) -import Data.Functor ( (<&>) ) -import System.Posix ( FileStatus, getFileStatus, isRegularFile ) -import Text.Printf ( printf ) +{-# LANGUAGE OverloadedRecordDot #-} -import Photoname.Common - ( CopySwitch (..), Links, MoveSwitch (..), NoActionSwitch (..) - , Options (..), Ph, SrcPath (..), runRename - ) -import Photoname.CopyLink ( createNewLink ) -import Photoname.Date ( PhDate, parseExifDate, parseFilenameDate ) -import Photoname.Exif ( getExifDate ) -import Photoname.Exiv2 ( setArtist, setExifDate ) -import Photoname.Links ( describeHardLinkPolicy, linksTest ) -import Photoname.Log ( errorM, initLogging, infoM, lname ) -import Photoname.Opts ( parseOpts ) +import Control.Monad (filterM, forM_, when) +import Data.Functor ((<&>)) +import System.Posix (FileStatus, getFileStatus, isRegularFile) +import Text.Printf (printf) +import Photoname.Common (CopySwitch (v), + Extension (Extension, UseExistingExtension), Links, MoveSwitch (v), + NoActionSwitch (v), Options (copy, extension, links, move, noAction, paths, + verbosity), Ph, SrcPath (SrcPath, v), liftIO, runRename) +import Photoname.CopyLink (createNewLink) +import Photoname.Date (PhDate, parseExifDate, parseFilenameDate) +import Photoname.Exif (getExifDate) +import Photoname.Exiv2 (getExifDateWithExiv2, setArtist, setExifDate) +import Photoname.Links (describeHardLinkPolicy, linksTest) +import Photoname.Log (errorM, initLogging, infoM, lname) +import Photoname.Opts (parseOpts) + acquireDate :: SrcPath -> Ph PhDate acquireDate srcPath = do - dateString <- getExifDate srcPath - pure $ mconcat - [ parseExifDate dateString - , parseFilenameDate srcPath + mconcat <$> sequence + [ parseExifDate <$> getExifDate srcPath + , parseExifDate <$> getExifDateWithExiv2 srcPath + , pure . parseFilenameDate $ srcPath ] processFile :: SrcPath -> Ph () processFile srcPath = do + liftIO . infoM lname $ "----------" imageDate <- acquireDate srcPath destPath <- createNewLink imageDate srcPath setExifDate imageDate destPath @@ -50,29 +52,33 @@ main = do opts <- parseOpts - initLogging $ optVerbosity opts + initLogging $ verbosity opts -- Notify user of the switches that will be in effect. - when (op NoActionSwitch . optNoAction $ opts) $ - infoM lname "No-action mode, nothing will be changed." + when opts.noAction.v $ + infoM lname "No-action mode, nothing will be changed" - when (op CopySwitch . optCopy $ opts) $ - infoM lname "Copy has been specified instead of the default of hard linking." + when opts.copy.v $ + infoM lname "Files will be copied instead of the default of hard linking" - when (op MoveSwitch . optMove $ opts) $ - infoM lname "Removing original links after new links are in place." + case opts.extension of + Extension ext -> infoM lname $ printf "The extension '%s' will be used for all files" ext + UseExistingExtension -> pure () - describeHardLinkPolicy $ optLinks opts + when opts.move.v $ + infoM lname "Removing original links after new links are in place" - actualPaths <- filterWantedFiles (optLinks opts) (optPaths opts) + describeHardLinkPolicy $ links opts + actualPaths <- filterWantedFiles (links opts) (paths opts) + -- Do the link manipulations, and report any errors. forM_ actualPaths $ \srcPath -> do result <- runRename opts $ processFile srcPath either {- HLINT ignore "Avoid lambda" -} -- Because the compiler can't figure out printf is expecting an argument at compile time - (\em -> errorM lname $ printf "** Processing %s: %s\n" (op SrcPath srcPath) em) + (\em -> errorM lname $ printf "** Processing %s: %s" srcPath.v em) pure result -- Perhaps we should get an ExitCode back from all this above? diff --git a/src/lib/Photoname/Common.hs b/src/lib/Photoname/Common.hs --- a/src/lib/Photoname/Common.hs +++ b/src/lib/Photoname/Common.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} module Photoname.Common ( Artist (..) , ConfigPath (..) , CopySwitch (..) , DestPath (..) + , Extension (..) , Links(..) , MoveSwitch (..) , NoActionSwitch (..) @@ -16,6 +17,7 @@ , SrcPath (..) , Suffix (..) , Verbosity (..) + , defaultDateTimeFormat , readVerbosity , runRename @@ -27,15 +29,17 @@ ) where -import Control.Monad.Except ( ExceptT, MonadError, runExceptT, throwError ) -import Control.Monad.Reader ( ReaderT, ask, asks, runReaderT ) -import Control.Monad.Trans ( liftIO ) -import Control.Newtype.Generics -import GHC.Generics -import System.Log.Logger ( Priority (..) ) -import System.Posix ( CNlink ) +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) +import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) +import Control.Monad.Trans (liftIO) +import Data.Time.LocalTime (LocalTime) +import System.Log.Logger (Priority (..)) +import System.Posix (CNlink) +defaultDateTimeFormat :: String +defaultDateTimeFormat = "%Y%m%d-%H%M%S" + data Verbosity = Quiet | Verbose Priority @@ -59,68 +63,47 @@ newtype ConfigPath = ConfigPath FilePath -newtype CopySwitch = CopySwitch Bool - deriving Generic +newtype CopySwitch = CopySwitch { v :: Bool } -instance Newtype CopySwitch +type DateFormatter = LocalTime -> String -newtype NoDirsSwitch = NoDirsSwitch Bool - deriving Generic +newtype NoDirsSwitch = NoDirsSwitch { v :: Bool } -instance Newtype NoDirsSwitch +data Extension = Extension FilePath | UseExistingExtension data Links = Exactly CNlink | NoLimit -newtype MoveSwitch = MoveSwitch Bool - deriving Generic - -instance Newtype MoveSwitch - -newtype NoActionSwitch = NoActionSwitch Bool - deriving Generic - -instance Newtype NoActionSwitch - -newtype ParentDir = ParentDir FilePath - deriving Generic - -instance Newtype ParentDir +newtype MoveSwitch = MoveSwitch { v :: Bool } -newtype Prefix = Prefix String - deriving Generic +newtype NoActionSwitch = NoActionSwitch { v :: Bool } -instance Newtype Prefix +newtype ParentDir = ParentDir { v :: FilePath } -newtype Suffix = Suffix String - deriving Generic +newtype Prefix = Prefix { v :: String } -instance Newtype Suffix +newtype Suffix = Suffix { v :: String } data Options = Options - { optArtist :: Maybe Artist - , optConfig :: Maybe ConfigPath - , optCopy :: CopySwitch - , optNoDirs :: NoDirsSwitch - , optLinks :: Links - , optMove :: MoveSwitch - , optNoAction :: NoActionSwitch - , optParentDir :: ParentDir - , optPrefix :: Prefix - , optSuffix :: Suffix - , optVerbosity :: Verbosity - , optPaths :: [FilePath] + { artist :: Maybe Artist + , config :: Maybe ConfigPath + , copy :: CopySwitch + , noDirs :: NoDirsSwitch + , extension :: Extension + , formatter :: DateFormatter + , links :: Links + , move :: MoveSwitch + , noAction :: NoActionSwitch + , parentDir :: ParentDir + , prefix :: Prefix + , suffix :: Suffix + , verbosity :: Verbosity + , paths :: [FilePath] } -newtype SrcPath = SrcPath FilePath - deriving Generic - -instance Newtype SrcPath +newtype SrcPath = SrcPath { v :: FilePath } newtype DestPath = DestPath FilePath - deriving Generic - -instance Newtype DestPath type Ph a = ReaderT Options (ExceptT String IO) a diff --git a/src/lib/Photoname/CopyLink.hs b/src/lib/Photoname/CopyLink.hs --- a/src/lib/Photoname/CopyLink.hs +++ b/src/lib/Photoname/CopyLink.hs @@ -1,37 +1,40 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedRecordDot, ScopedTypeVariables #-} module Photoname.CopyLink ( createNewLink ) where -import Control.Exception ( try ) -import Control.Monad ( unless, when ) -import Control.Newtype.Generics ( op ) -import Data.Time.LocalTime ( LocalTime ) -import GHC.IO.Exception ( IOException ) -import System.Directory ( copyFile, createDirectoryIfMissing ) -import System.FilePath ( (), takeDirectory ) -import System.Posix ( createLink, fileExist, removeLink ) -import Text.Printf ( printf ) +import Control.Exception (try) +import Control.Monad (unless, when) +import Data.Time.LocalTime (LocalTime) +import GHC.IO.Exception (IOException) +import System.Directory (copyFile, createDirectoryIfMissing) +import System.FilePath ((), (<.>), takeDirectory, takeExtension) +import System.Posix (createLink, fileExist, removeLink) -import Photoname.Common ( CopySwitch (..), DestPath (..), MoveSwitch (..), - NoActionSwitch (..), NoDirsSwitch (..), ParentDir (..), Options (..), - Ph, Prefix (..), SrcPath (..), Suffix (..), - ask, asks, liftIO, throwError ) -import Photoname.Date - ( PhDate (ExifDate, FilenameDate, NoDateFound) - , formatDateHyphens, formatDateTime, formatYear - ) -import Photoname.Log ( lname, noticeM, warningM ) +import Photoname.Common (CopySwitch (v), DestPath (..), + Extension (Extension, UseExistingExtension), MoveSwitch (v), + NoActionSwitch (v), NoDirsSwitch (NoDirsSwitch), ParentDir (ParentDir), + Options (copy, formatter, extension, move, noAction, noDirs, parentDir, prefix, suffix), + Ph, Prefix (Prefix), SrcPath (SrcPath), Suffix (Suffix), ask, asks, liftIO, + throwError) +import Photoname.Date (PhDate (ExifDate, FilenameDate, NoDateFound), + formatDateHyphens, formatYear) +import Photoname.Log (lname, noticeM, warningM) createNewLink :: PhDate -> SrcPath -> Ph DestPath createNewLink imageDate srcPath@(SrcPath srcFp) = do opts <- ask + + let ext = case opts.extension of + (Extension ext') -> ext' + UseExistingExtension -> takeExtension srcFp + destPath@(DestPath destFp) <- case imageDate of - ExifDate lt -> buildDatePath lt - FilenameDate lt -> buildDatePath lt + ExifDate lt -> buildDatePath lt ext + FilenameDate lt -> buildDatePath lt ext NoDateFound -> throwError "Could not extract any date information" -- Check for existence of the target file @@ -41,17 +44,17 @@ -- Display what will be done liftIO $ noticeM lname $ srcFp ++ " -> " ++ destFp - unless (op NoActionSwitch . optNoAction $ opts) $ do + unless opts.noAction.v $ do -- Make the target dir liftIO $ createDirectoryIfMissing True $ takeDirectory destFp -- Make the new file - if op CopySwitch . optCopy $ opts + if opts.copy.v then liftIO $ copyFile srcFp destFp else tryHardLink srcPath destPath -- If user has specified, remove the original link - when (op MoveSwitch . optMove $ opts) $ + when opts.move.v $ liftIO $ removeLink srcFp pure destPath @@ -72,15 +75,16 @@ dir, subdirs wanted or not, prefix and suffix, and the date info that was gathered). -} -buildDatePath :: LocalTime -> Ph DestPath -buildDatePath date = do - prefixStr <- asks (op Prefix . optPrefix) - suffixStr <- asks (op Suffix . optSuffix) - let fileName = printf "%s%s%s.jpg" prefixStr (formatDateTime date) suffixStr +buildDatePath :: LocalTime -> FilePath -> Ph DestPath +buildDatePath date ext = do + (Prefix prefixStr) <- asks prefix + (Suffix suffixStr) <- asks suffix + dateFormatter <- asks formatter + let fileName = prefixStr <> dateFormatter date <> suffixStr - parentFp <- asks (op ParentDir . optParentDir) - noDirs <- asks (op NoDirsSwitch . optNoDirs) - pure . DestPath $ if noDirs - then parentFp fileName - else parentFp formatYear date - formatDateHyphens date fileName + (ParentDir parentDir') <- asks parentDir + (NoDirsSwitch noDirs') <- asks noDirs + pure . DestPath $ if noDirs' + then parentDir' fileName <.> ext + else parentDir' formatYear date + formatDateHyphens date fileName <.> ext diff --git a/src/lib/Photoname/Date.hs b/src/lib/Photoname/Date.hs --- a/src/lib/Photoname/Date.hs +++ b/src/lib/Photoname/Date.hs @@ -5,22 +5,22 @@ ( PhDate (..) , formatYear, formatDateHyphens, formatDate, formatDateTime , formatDateForExif + , mkDateFormatter , parseExifDate , parseFilenameDate ) where -import Control.Newtype.Generics ( op ) -import Data.Functor.Identity ( Identity ) -import Data.Time.Calendar ( fromGregorian ) -import Data.Time.Format ( defaultTimeLocale, formatTime ) -import Data.Time.LocalTime ( LocalTime (..), TimeOfDay (..) ) -import System.FilePath ( takeFileName ) -import Text.Parsec ( ParsecT ) -import Text.ParserCombinators.Parsec ( anyChar, char, count, digit, - lookAhead, manyTill, parse, space, try ) +import Data.Functor.Identity (Identity) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) +import System.FilePath (takeFileName) +import Text.Parsec (ParsecT) +import Text.ParserCombinators.Parsec (anyChar, char, count, digit, + lookAhead, manyTill, parse, space, try) -import Photoname.Common ( SrcPath (..) ) +import Photoname.Common (SrcPath (SrcPath), defaultDateTimeFormat) data PhDate @@ -50,7 +50,7 @@ {- Parse a string in the form "yyyy:mm:dd hh:mm:ss" into a - CalendarTime datatype. Strings that fail to parse in this manner are + LocalTime datatype. Strings that fail to parse in this manner are returned as Nothing -} parseExifDate :: Maybe String -> PhDate @@ -72,7 +72,7 @@ (fromIntegral (read second :: Integer))) -{- Parse a string in one of the the forms below into a CalendarTime datatype. +{- Parse a string in one of the the forms below into a LocalTime datatype. /some/path/ANYTHINGyyyy-mm-dd-hhmmss.jpg /some/path/ANYTHINGyyyy-mm-dd-hh-mm-ss-ttt.jpg @@ -84,8 +84,8 @@ PXL_yyyymmdd_hhmmssttt_xyz.jpg -} parseFilenameDate :: SrcPath -> PhDate -parseFilenameDate srcPath = - case parse dateParser "" (takeFileName . op SrcPath $ srcPath) of +parseFilenameDate (SrcPath srcPath) = + case parse dateParser "" (takeFileName srcPath) of Left _ -> NoDateFound Right x -> FilenameDate x where @@ -109,31 +109,35 @@ (fromIntegral (read second :: Integer))) -{- Format a Maybe CalendarTime into a "yyyy" string +{- Format a LocalTime into a "yyyy" string -} formatYear :: LocalTime -> String formatYear = formatTime defaultTimeLocale "%Y" -{- Format a Maybe CalendarTime into a "yyyy-mm-dd" string +{- Format a LocalTime into a "yyyy-mm-dd" string -} formatDateHyphens :: LocalTime -> String formatDateHyphens = formatTime defaultTimeLocale "%Y-%m-%d" -{- Format a Maybe CalendarTime into a "yyyymmdd" string +{- Format a LocalTime into a "yyyymmdd" string -} formatDate :: LocalTime -> String formatDate = formatTime defaultTimeLocale "%Y%m%d" -{- Format a Maybe CalendarTime into a "yyyymmdd-HHMMSS" string +{- Format a LocalTime into a "yyyymmdd-HHMMSS" string -} formatDateTime :: LocalTime -> String -formatDateTime = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" +formatDateTime = mkDateFormatter defaultDateTimeFormat -{- Format a Maybe CalendarTime into a "yyyy:mm:dd HH:MM:SS" string +{- Format a LocalTime into a "yyyy:mm:dd HH:MM:SS" string -} formatDateForExif :: LocalTime -> String formatDateForExif = formatTime defaultTimeLocale "%Y:%m:%d %H:%M:%S" + + +mkDateFormatter :: String -> LocalTime -> String +mkDateFormatter = formatTime defaultTimeLocale diff --git a/src/lib/Photoname/Exif.hs b/src/lib/Photoname/Exif.hs --- a/src/lib/Photoname/Exif.hs +++ b/src/lib/Photoname/Exif.hs @@ -5,14 +5,13 @@ ) where -import Control.Monad.Except ( MonadIO, liftIO ) -import Control.Newtype.Generics ( ala ) +import Control.Monad.Except (MonadIO, liftIO) import qualified Data.Map as M -import Data.Monoid ( First (..) ) -import Graphics.HsExif ( ExifTag, ExifValue, dateTime, dateTimeDigitized, - dateTimeOriginal, parseFileExif ) +import Data.Monoid (First (..)) +import Graphics.HsExif (ExifTag, ExifValue, dateTime, dateTimeDigitized, + dateTimeOriginal, parseFileExif) -import Photoname.Common ( SrcPath (..) ) +import Photoname.Common (SrcPath (SrcPath)) {- @@ -31,6 +30,10 @@ extractDate :: Either String (M.Map ExifTag ExifValue) -> Maybe String extractDate (Left _) = Nothing extractDate (Right exifMap) = - -- Find the first date available in the Map - show <$> ala First foldMap (map (flip M.lookup exifMap) - [dateTimeOriginal, dateTimeDigitized, dateTime]) + show <$> -- Turn the (Maybe ExifValue) into a (Maybe String) + ( getFirst -- Remove the First wrapper + . mconcat -- Collapse these to the first not-Nothing + -- Look up all of them (resulting in [Maybe ExifValue]), wrap in First data structures + . map (First . flip M.lookup exifMap) + -- EXIF tags we're intersted in, in the order we want them left-to-right + $ [dateTimeOriginal, dateTimeDigitized, dateTime]) diff --git a/src/lib/Photoname/Exiv2.hs b/src/lib/Photoname/Exiv2.hs --- a/src/lib/Photoname/Exiv2.hs +++ b/src/lib/Photoname/Exiv2.hs @@ -1,52 +1,121 @@ module Photoname.Exiv2 - ( setArtist + ( getExifDateWithExiv2 + , setArtist , setExifDate ) where -import Control.Monad ( unless ) -import Control.Newtype.Generics ( op ) -import System.Process ( callCommand ) -import Text.Printf ( printf ) +import Control.Exception +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import Data.Char (isSpace) +import GHC.IO.Exception +import System.Process hiding (proc) +import qualified System.Process as Proc +import Text.Printf (printf) -import Photoname.Common ( Artist (..), DestPath (..), NoActionSwitch (..), - Options (..), Ph, ask, liftIO ) -import Photoname.Date ( PhDate (FilenameDate), formatDateForExif ) -import Photoname.Log ( lname, noticeM ) +import Photoname.Common (Artist (Artist), DestPath (DestPath), + NoActionSwitch (NoActionSwitch), Options (artist, noAction), Ph, + SrcPath (SrcPath), asks, liftIO) +import Photoname.Date (PhDate (FilenameDate), formatDateForExif) +import Photoname.Log (LogFunction, debugM, infoM, lname, noticeM) -newtype Command = Command { unCommand :: String } +data Reading +data Writing +-- For logging purposes we keep the program name separate from its arguments +-- until we need to build a CreateProcess data structure +data Command rw = Command LogFunction FilePath [String] -execCommands :: [Command] -> Ph () -execCommands commands = do - opts <- ask +-- Construct a human-readable command-line from a Command data structure. This +-- is purely for logging. +-- Arguments may contain spaces but be quoted properly when this is used by +-- System.Process.proc BUT they look odd when logged by our code. This function +-- will put quotes around any space-containing arguments purely for human +-- readability. +commandToString :: Command rw -> String +commandToString (Command _ program' arguments) = + unwords $ program' : map quoteAsNeeded arguments + where + quoteAsNeeded str = if ' ' `elem` str + then "'" <> str <> "'" + else str - -- Display what will be done - liftIO $ mapM_ (noticeM lname . unCommand) commands +proc :: Command rw -> CreateProcess +proc (Command _ program' arguments) = Proc.proc program' arguments - -- Execute the commands - unless (op NoActionSwitch . optNoAction $ opts) $ - liftIO $ mapM_ (callCommand . unCommand) commands +logCommand :: MonadIO m => Command rw -> m () +logCommand command@(Command logFunction _ _) = + liftIO . logFunction lname . commandToString $ command + + +-- For Writing (or "destructive") commands, we need to check if the user has +-- chosen no-action behavior before executing +execWritingCommand :: Command Writing -> Ph (Either String String) +execWritingCommand command = do + logCommand command + (NoActionSwitch noAction') <- asks noAction + if noAction' + then pure $ Left "" + else execCommand command + + +-- For Reading (or "non-destructive") commands, we just log it and do it +execReadingCommand :: Command Reading -> Ph (Either String String) +execReadingCommand command = logCommand command >> execCommand command + + +stripTrailingWhitespace :: String -> String +stripTrailingWhitespace = reverse . dropWhile isSpace . reverse + + +execCommand :: Command rw -> Ph (Either String String) +execCommand command = liftIO $ do + eResult <- postProcess =<< try (readCreateProcessWithExitCode (proc command) "") + either (\msg -> debugM lname $ "** Command failed: " <> stripTrailingWhitespace msg) + (\output -> debugM lname $ "Command succeeded, output: " <> stripTrailingWhitespace output) eResult + pure eResult + + +program :: FilePath +program = "exiv2" + + +postProcess :: Either IOException (ExitCode, String, String) -> IO (Either String String) +postProcess (Left e ) = pure . Left $ printf "%s: %s" program (ioe_description e) +postProcess (Right (ExitSuccess , stdOut, _ )) = pure . Right $ stdOut +postProcess (Right (ExitFailure 1, _ , "" )) = pure . Left $ "EXIF tag not found" +postProcess (Right (ExitFailure _, _ , stdErr)) = pure . Left $ stdErr + + setArtist :: DestPath -> Ph () setArtist (DestPath destFp) = do - opts <- ask + artist' <- asks artist - case optArtist opts of + case artist' of Nothing -> pure () - Just (Artist "") -> execCommands . map Command $ - [ printf "exiv2 --Modify 'del Exif.Image.Artist' %s" destFp ] - Just (Artist artistInfo) -> execCommands . map Command $ - [ printf "exiv2 --Modify 'set Exif.Image.Artist %s' %s" artistInfo destFp ] + Just (Artist "") -> void $ execWritingCommand $ + Command noticeM program ["--Modify", "del Exif.Image.Artist", destFp] + Just (Artist artistInfo) -> void $ execWritingCommand $ + Command noticeM program ["--Modify", "set Exif.Image.Artist " <> artistInfo, destFp] +getExifDateWithExiv2 :: SrcPath -> Ph (Maybe String) +getExifDateWithExiv2 (SrcPath srcFp) = do + let tag = "Exif.Image.DateTime" + eResult <- execReadingCommand $ Command infoM program ["--Print", "v", "--grep", tag, srcFp] + pure . either (const Nothing) Just $ eResult + + setExifDate :: PhDate -> DestPath -> Ph () setExifDate (FilenameDate lt) (DestPath destFp) = - execCommands . map Command $ - [ printf "exiv2 --Modify 'set Exif.Image.DateTime Ascii %s' --Modify 'set Exif.Photo.UserComment charset=Ascii DateTime is a guess' %s" (formatDateForExif lt) destFp + void $ execWritingCommand . Command noticeM program $ + [ "--Modify", "set Exif.Image.DateTime Ascii " <> formatDateForExif lt + , "--Modify", "set Exif.Photo.UserComment charset=Ascii DateTime is a guess", destFp ] setExifDate _ _ = pure () diff --git a/src/lib/Photoname/Links.hs b/src/lib/Photoname/Links.hs --- a/src/lib/Photoname/Links.hs +++ b/src/lib/Photoname/Links.hs @@ -4,11 +4,11 @@ ) where -import System.Posix ( FileStatus, linkCount ) -import Text.Printf ( printf ) +import System.Posix (FileStatus, linkCount) +import Text.Printf (printf) -import Photoname.Common ( Links (Exactly, NoLimit) ) -import Photoname.Log ( infoM, lname ) +import Photoname.Common (Links (Exactly, NoLimit)) +import Photoname.Log (infoM, lname) linksTest :: Links -> FileStatus -> Bool diff --git a/src/lib/Photoname/Log.hs b/src/lib/Photoname/Log.hs --- a/src/lib/Photoname/Log.hs +++ b/src/lib/Photoname/Log.hs @@ -1,5 +1,6 @@ module Photoname.Log - ( initLogging + ( LogFunction + , initLogging , lname , logTest @@ -8,13 +9,23 @@ ) where -import System.IO ( Handle, stdout ) -import System.Log.Handler.Simple ( GenericHandler, streamHandler ) +import Data.Functor ((<&>)) +import System.IO (Handle, stdout) +import System.Log.Formatter (simpleLogFormatter) +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (GenericHandler, streamHandler) import System.Log.Logger + ( Priority (DEBUG) + , alertM, criticalM, debugM, emergencyM, errorM, infoM, noticeM, warningM + , rootLoggerName, setHandlers, setLevel, updateGlobalLogger + ) -import Photoname.Common ( Verbosity (Quiet, Verbose) ) +import Photoname.Common (Verbosity (Quiet, Verbose)) +type LogFunction = String -> String -> IO () + + lname :: String lname = rootLoggerName @@ -28,7 +39,15 @@ handlers :: Verbosity -> IO [GenericHandler Handle] + handlers Quiet = pure [] + +-- Under the maximum verbosity (-v3), also display the logging Priority +handlers (Verbose DEBUG) = do + h <- streamHandler stdout DEBUG <&> + flip setFormatter (simpleLogFormatter "$prio: $msg") + pure [h] + handlers (Verbose _) = sequence [streamHandler stdout DEBUG] diff --git a/src/tests/Photoname/Test/EndToEnd/Link.hs b/src/tests/Photoname/Test/EndToEnd/Link.hs --- a/src/tests/Photoname/Test/EndToEnd/Link.hs +++ b/src/tests/Photoname/Test/EndToEnd/Link.hs @@ -5,11 +5,11 @@ ) where -import System.Directory ( copyFile, removeDirectoryRecursive, removeFile ) -import System.FilePath.Posix ( (), (<.>) ) -import System.Posix.Files ( fileExist ) -import System.Process ( waitForProcess ) -import Text.Regex.Posix ( (=~) ) +import System.Directory (copyFile, removeDirectoryRecursive, removeFile) +import System.FilePath.Posix ((), (<.>)) +import System.Posix.Files (fileExist) +import System.Process (waitForProcess) +import Text.Regex.Posix ((=~)) import Test.Tasty import Test.Tasty.HUnit import qualified Photoname.Test.EndToEnd.Util as Util diff --git a/src/tests/Photoname/Test/EndToEnd/Util.hs b/src/tests/Photoname/Test/EndToEnd/Util.hs --- a/src/tests/Photoname/Test/EndToEnd/Util.hs +++ b/src/tests/Photoname/Test/EndToEnd/Util.hs @@ -5,9 +5,9 @@ ) where -import System.IO ( hGetContents ) -import System.Process ( ProcessHandle, runInteractiveCommand ) -import Test.Tasty.HUnit ( Assertion, assertBool ) +import System.IO (hGetContents) +import System.Process (ProcessHandle, runInteractiveCommand) +import Test.Tasty.HUnit (Assertion, assertBool) command :: String diff --git a/src/tests/Photoname/Test/Unit/Date.hs b/src/tests/Photoname/Test/Unit/Date.hs --- a/src/tests/Photoname/Test/Unit/Date.hs +++ b/src/tests/Photoname/Test/Unit/Date.hs @@ -6,10 +6,11 @@ ) where +import Data.Foldable (fold) import Data.Time.Calendar import Data.Time.LocalTime -import Photoname.Common ( SrcPath (..) ) -import Photoname.Date ( PhDate (..), parseExifDate, parseFilenameDate ) +import Photoname.Common (SrcPath (..)) +import Photoname.Date (PhDate (..), parseExifDate, parseFilenameDate) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -80,5 +81,5 @@ , testProperty "Monoid left identity mempty <> x == x" $ \(x :: PhDate) -> mempty <> x == x , testProperty "Monoid concatenation mconcat xs == foldr (<>) mempty xs" $ - \(xs :: [PhDate]) -> mconcat xs == foldr (<>) mempty xs + \(xs :: [PhDate]) -> mconcat xs == fold xs ] diff --git a/src/tests/runtests.hs b/src/tests/runtests.hs --- a/src/tests/runtests.hs +++ b/src/tests/runtests.hs @@ -1,7 +1,7 @@ module Main where -import System.Environment ( getArgs, withArgs ) +import System.Environment (getArgs, withArgs) import Test.Tasty import qualified Photoname.Test.EndToEnd.Link as Link diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,10 @@ -resolver: nightly-2021-11-15 +resolver: lts-21.25 packages: - . -extra-deps: [] +extra-deps: +- hsexif-0.6.1.10 flags: hsexif: diff --git a/stack.yaml.lock b/stack.yaml.lock --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,17 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: hsexif-0.6.1.10@sha256:f002993b7953186a9e13869efe830ce951b900ee504afdbc297950f3b88fc3e3,2276 + pantry-tree: + sha256: 25066251bd371301fa2d8e693d5e84828ceee2a02e2ee7f1523065fc2cbf72db + size: 1120 + original: + hackage: hsexif-0.6.1.10 snapshots: - completed: - size: 596363 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/11/15.yaml - sha256: 4eb51ee07b71a0e11a4a9d32020ce6a5305e5a2f17da739afecdf7e876c78fec - original: nightly-2021-11-15 + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/util/resources/test/dateTime.webp b/util/resources/test/dateTime.webp new file mode 100644 Binary files /dev/null and b/util/resources/test/dateTime.webp differ