photoname 5.1 → 5.2
raw patch · 21 files changed
+448/−367 lines, 21 filesdep −newtype-genericsbinary-added
Dependencies removed: newtype-generics
Files
- .gitignore +2/−5
- LICENSE +1/−1
- changelog.md +20/−0
- package.yaml +0/−77
- photoname.cabal +90/−71
- src/app/Photoname/Opts.hs +38/−13
- src/app/photoname.hs +36/−30
- src/lib/Photoname/Common.hs +36/−53
- src/lib/Photoname/CopyLink.hs +39/−35
- src/lib/Photoname/Date.hs +24/−20
- src/lib/Photoname/Exif.hs +12/−9
- src/lib/Photoname/Exiv2.hs +95/−26
- src/lib/Photoname/Links.hs +4/−4
- src/lib/Photoname/Log.hs +23/−4
- src/tests/Photoname/Test/EndToEnd/Link.hs +5/−5
- src/tests/Photoname/Test/EndToEnd/Util.hs +3/−3
- src/tests/Photoname/Test/Unit/Date.hs +4/−3
- src/tests/runtests.hs +1/−1
- stack.yaml +3/−2
- stack.yaml.lock +12/−5
- util/resources/test/dateTime.webp binary
.gitignore view
@@ -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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2007-2021, Dino Morelli <dino@ui3.info>+Copyright (c) 2007, Dino Morelli <dino@ui3.info> Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided
changelog.md view
@@ -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
− package.yaml
@@ -1,77 +0,0 @@-name: photoname-version: '5.1'-license: ISC-copyright: 2007-2021 Dino Morelli-author: Dino Morelli-maintainer: Dino Morelli <dino@ui3.info>-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
photoname.cabal view
@@ -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 <dino@ui3.info>-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 <dino@ui3.info>+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
src/app/Photoname/Opts.hs view
@@ -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 @@ <PARENTDIR>/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
src/app/photoname.hs view
@@ -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?
src/lib/Photoname/Common.hs view
@@ -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
src/lib/Photoname/CopyLink.hs view
@@ -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
src/lib/Photoname/Date.hs view
@@ -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
src/lib/Photoname/Exif.hs view
@@ -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])
src/lib/Photoname/Exiv2.hs view
@@ -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 ()
src/lib/Photoname/Links.hs view
@@ -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
src/lib/Photoname/Log.hs view
@@ -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]
src/tests/Photoname/Test/EndToEnd/Link.hs view
@@ -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
src/tests/Photoname/Test/EndToEnd/Util.hs view
@@ -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
src/tests/Photoname/Test/Unit/Date.hs view
@@ -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 ]
src/tests/runtests.hs view
@@ -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
stack.yaml view
@@ -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:
stack.yaml.lock view
@@ -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
+ util/resources/test/dateTime.webp view
binary file changed (absent → 59372 bytes)