diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,8 @@ # Vim swap files *.sw? -# stack build artifacts +# Stack uses this directory as scratch space. .stack-work/ + +# Stack generates the Cabal file from `package.yaml` through hpack. +/*.cabal diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2007-2016, Dino Morelli +Copyright (c) 2007-2021, 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,24 +13,31 @@ photo shoot date information contained within the file's EXIF tags. +## Getting binaries + +photoname is available for Linux in AppImage form [from github](https://github.com/dino-/photoname/releases) + + ## Getting source -- Download the cabalized source package [from Hackage](http://hackage.haskell.org/package/photoname) -- epub-tools is available for Arch Linux [from the AUR](https://aur.archlinux.org/packages/photoname/) - Get the source with git: `$ git clone https://github.com/dino-/photoname.git` -- If you're just looking, [browse the source](https://github.com/dino-/photoname) +- Download the cabalized source package [from Hackage](http://hackage.haskell.org/package/photoname) And once you have it, building the usual way: $ stack build + $ stack run $ stack test $ stack clean +If you're just looking, [browse the source](https://github.com/dino-/photoname) -## Installing -Build and install with the included `install.hs` script: - `# ./util/install.hs --prefix=/some/dir` +## Building for release + +For Linux builds, I recommend using the excellent +[hsinstall](https://github.com/dino-/hsinstall) utility which will simplify +creation of an [AppImage](https://appimage.org/) executable. ## Contact diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/TODO.md b/TODO.md deleted file mode 100644 --- a/TODO.md +++ /dev/null @@ -1,8 +0,0 @@ -- Allow user to specify permissions for newly-created dirs and - files. Bonus points for parsing the octal codes everyone knows - and loves. -- Add a `--force` switch to disregard existing links. -- 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. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,92 +1,140 @@ +5.0 (2020-11-26) + + * Updated Stackage resolver + * Moved copyright date up to 2021 + * Moved Photoname.Opts module into the app src tree + * Removed the useless tests for program help + * Switched to optparse-applicative for arg parsing + * cabalized projects no longer need a Setup.hs + * Added the -a|--artist option + * Changed lookup order of EXIF date tags + * Added ability to parse the filename for date and time + * Fixed broken smoke tests + * Switched test suite to use Tasty + * Attempt to copy if the hard link fails + * Added new --copy switch and behavior + * Moved AppImage desktop and icon into hsinstall tree + * Added new --prefix switch and behavior + * Output is now handled via hslogger + * Now using newtype wrappers nearly everywhere + + +4.1 (2019-03-30) + + * Removed some AppImage desktop file categories + + +4.0 (2019-03-26) + + * All imports are now explicit + * Added tests for several missing cases + * Removed --old-style switch and behavior + * Removed unnecessary Control.Applicative imports + * Switched EXIF library from from exif to hsexif + * Removed unused old-locale dep + * Removed License and Author comments from source code + * Moved copyright up to 2019 + * Redesign source code directory layout + * Removed outdated TODO.md and doc/dev/notes files + * Updated build to use hpack and hsinstall + + +3.4 (2018-10-09) + + * Added a new --version switch + * Now supporting building to an AppImage + * Moved copyright up to 2018 + + 3.3 (2017-12-27) - * A variety of build-related fixes were made + * A variety of build-related fixes were made 3.2 (2016-10-02) - * Switched the build from cabal to stack - * Added hsinstall installation script - * Update copyright year - * Various updates to the cabal file + * Switched the build from cabal to stack + * Added hsinstall installation script + * Update copyright year + * Various updates to the cabal file 3.1 (2015-06-28) - * Removed ambiguous import of `System.Locale.defaultTimeLocale` - * Updated to use `Data.Version` to fish the version out of cabal info - * Replaced deprecated ErrorT with ExceptT - * Added pragma for Control.Applicative import - * Updated README and cabal file with current info - * Moved copyright year up to 2015 + * Removed ambiguous import of `System.Locale.defaultTimeLocale` + * Updated to use `Data.Version` to fish the version out of cabal info + * Replaced deprecated ErrorT with ExceptT + * Added pragma for Control.Applicative import + * Updated README and cabal file with current info + * Moved copyright year up to 2015 3.0.1 (2012-11-01) - * Updated test suite to build cleanly (without warnings) and - run against modern cabal versions - * Updated cabal file to modern cabal standards. Unit testing is - now cabal-driven and we now fully support cabal sdist. - * Fixed a problem where try is no longer available. Now importing - Control.Exception to bring it into scope. - * Adjusted usage to explain a change in how we find the EXIF - date stamps - * Moved copyright year up to 2012 + * Updated test suite to build cleanly (without warnings) and + run against modern cabal versions + * Updated cabal file to modern cabal standards. Unit testing is + now cabal-driven and we now fully support cabal sdist. + * Fixed a problem where try is no longer available. Now importing + Control.Exception to bring it into scope. + * Adjusted usage to explain a change in how we find the EXIF + date stamps + * Moved copyright year up to 2012 3.0.0 (2011-05-08) - * New naming scheme that uses date/time only, no serial. This - is a BIG change but the old naming scheme is still available. - * Parent directory is now a switch - * Subdirectory path creation of year and day can be suppressed - * User can specify an arbitrary suffix string for the new names - * User can now put switches into a config file + * New naming scheme that uses date/time only, no serial. This + is a BIG change but the old naming scheme is still available. + * Parent directory is now a switch + * Subdirectory path creation of year and day can be suppressed + * User can specify an arbitrary suffix string for the new names + * User can now put switches into a config file 2.3.0 (2010-01-25) - * Problem fixed that had recently come up with the Exif - library. Specifically, files with no EXIF data were causing - an IO error to be thrown and processing to halt. (thanks to - Josh Hoyt) - * Other minor updates to things like copyright info and version - number + * Problem fixed that had recently come up with the Exif + library. Specifically, files with no EXIF data were causing + an IO error to be thrown and processing to halt. (thanks to + Josh Hoyt) + * Other minor updates to things like copyright info and version + number 2.2 (2009-06-07) - * No changes in how the software behaves - * Updated build-depends to be explicit about base version - requirement - * Minor update to BSD3 copyright notices to bring them up to 2009 - * Debian binary package of v2.2 available + * No changes in how the software behaves + * Updated build-depends to be explicit about base version + requirement + * Minor update to BSD3 copyright notices to bring them up to 2009 + * Debian binary package of v2.2 available 2.1 (2008-10-11) - * More big changes to the transformers used. No longer using - WriterT. Now using ErrorT for error handling. - * Changed to record-style data for the arg parsing. + * More big changes to the transformers used. No longer using + WriterT. Now using ErrorT for error handling. + * Changed to record-style data for the arg parsing. 2.0 (2008-03-05) - * Upgraded to build under GHC 6.8.2 - * Major internal changes. Now using ReaderT and WriterT - * Changed version numbering scheme to be more conventional. Recent - versions of cabal were not amused with the strange version - string. - * This project now added to HackageDB + * Upgraded to build under GHC 6.8.2 + * Major internal changes. Now using ReaderT and WriterT + * Changed version numbering scheme to be more conventional. Recent + versions of cabal were not amused with the strange version + string. + * This project now added to HackageDB 003 (2007-09-13) - * Repairs for a build problem with GHC > 6.6 specifically related - to depending on FilePath instead of filepath and now requiring - import of Data.Time.Format + * Repairs for a build problem with GHC > 6.6 specifically related + to depending on FilePath instead of filepath and now requiring + import of Data.Time.Format 002 (2007-04-28) - * Initial release + * Initial release diff --git a/doc/dev/notes b/doc/dev/notes deleted file mode 100644 --- a/doc/dev/notes +++ /dev/null @@ -1,41 +0,0 @@ ------ -- To change the app version: - - Edit photoname.cabal - - Edit src/Photoname/Opts.hs, usageText near the bottom of footer - - I'd like to make a script in util/ to automate this. - After such a script has been made, may want to put developer notes on using it in doc/dev/ - ----------- -File naming format: - -yyyymmdd_[oth_]nnn[-e[n]].jpg -yyyymmdd-hhmmss[_oth][_ss].jpg - -date: year month day -time: hour minute second -oth: could be photographer: 2 or 3 character initials -ss: edited or sized, optional number for more than one - _sp _ep : sized/edited for printing - _sd1920x1080 _ed : sized/edited for desktop - _sw _ew : sized/edited for web - - -These files are arranged into a dir structure - -top-level/ - 0000/ - 0000-00-00/ - 00000000_001.jpg -- Unknown pictures - 00000000_002.jpg - 2006/ - 2006-10-13/ - 20061013_431.jpg - 20061013_509.jpg - 2007/ - 2007-01-30/ - 20070130_002.jpg - 20070130_119-ew.jpg - 2007-04-19/ - 20070419_bmd_323.jpg - 20070419_bmd_325-sd.jpg diff --git a/hsinstall/share/applications/photoname.desktop b/hsinstall/share/applications/photoname.desktop new file mode 100644 --- /dev/null +++ b/hsinstall/share/applications/photoname.desktop @@ -0,0 +1,7 @@ +[Desktop Entry] +Name=photoname +Exec=photoname +Icon=photoname +Type=Application +Categories=Graphics;Photography;ConsoleOnly; +Terminal=true diff --git a/hsinstall/share/icons/hicolor/scalable/apps/photoname.svg b/hsinstall/share/icons/hicolor/scalable/apps/photoname.svg new file mode 100644 --- /dev/null +++ b/hsinstall/share/icons/hicolor/scalable/apps/photoname.svg @@ -0,0 +1,320 @@ + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,77 @@ +name: photoname +version: '5.0' +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,74 +1,118 @@ -name: photoname -cabal-version: >= 1.8 -version: 3.3 -build-type: Simple -license: ISC -license-file: LICENSE -copyright: 2007-2016 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.0.1 +cabal-version: 1.12 -extra-source-files: changelog.md - doc/dev/notes - doc/hcar-photoname.tex - .gitignore - README.md - stack.yaml - testsuite/resources/*.jpg - TODO.md - util/install.hs - util/resources/test.conf +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack -source-repository head - type: darcs - location: http://hub.darcs.net/dino/photoname +name: photoname +version: 5.0 +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 +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 -executable photoname - main-is: photoname.hs - build-depends: base >=4.5 && < 5.0 - , directory - , exif - , filepath - , mtl - , old-locale - , parsec - , time - , unix - other-modules: Paths_photoname - Photoname.Common - Photoname.DateFormat - Photoname.Date - Photoname.Exif - Photoname.Opts - Photoname.SerialFormat - hs-source-dirs: src - ghc-options: -Wall +source-repository head + type: git + location: https://github.com/dino-/photoname -test-suite photoname-tests - type: exitcode-stdio-1.0 - main-is: runtests.hs - build-depends: base >=4.5 && < 5.0 - , directory - , exif - , filepath - , HUnit - , mtl - , old-locale - , parsec - , process - , regex-posix - , time - , unix - other-modules: TestHelp - TestLink - Util - hs-source-dirs: src testsuite - ghc-options: -Wall +library + exposed-modules: + Photoname.Common + Photoname.CopyLink + Photoname.Date + Photoname.Exif + Photoname.Exiv2 + Photoname.Log + other-modules: + Paths_photoname + hs-source-dirs: + src/lib + ghc-options: -fwarn-tabs -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.5 && <5.0 + , containers + , directory + , filepath + , hsexif + , hslogger + , mtl + , newtype-generics + , parsec + , process + , time + , unix + default-language: Haskell2010 + +executable photoname + main-is: photoname.hs + other-modules: + Photoname.Opts + 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 + type: exitcode-stdio-1.0 + main-is: runtests.hs + other-modules: + Test.Photoname.Date + TestLink + Util + Paths_photoname + hs-source-dirs: + src/tests + ghc-options: -fwarn-tabs -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.5 && <5.0 + , directory + , filepath + , photoname + , process + , regex-posix + , tasty + , tasty-hunit + , tasty-quickcheck + , time + , unix + default-language: Haskell2010 diff --git a/src/Photoname/Common.hs b/src/Photoname/Common.hs deleted file mode 100644 --- a/src/Photoname/Common.hs +++ /dev/null @@ -1,25 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -module Photoname.Common - ( Ph, runRename - - -- Re-exporting: - , MonadError - , ask, asks - , liftIO - , throwError - ) - where - -import Control.Monad.Except -import Control.Monad.Reader - -import Photoname.Opts ( Options (..) ) - - -type Ph a = ReaderT Options (ExceptT String IO) a - - -runRename :: Options -> Ph a -> IO (Either String a) -runRename env action = runExceptT $ runReaderT action env diff --git a/src/Photoname/Date.hs b/src/Photoname/Date.hs deleted file mode 100644 --- a/src/Photoname/Date.hs +++ /dev/null @@ -1,72 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -module Photoname.Date - ( formatYear, formatDateHyphens, formatDate, formatDateTime - , readDate - ) - where - -import Data.Time.Calendar -import Data.Time.Format -import Data.Time.LocalTime -import Text.ParserCombinators.Parsec - - -{- Parse a date string in the form "yyyy:mm:dd hh:mm:ss" into a - CalendarTime datatype. Strings that fail to parse in this manner are - returned as Nothing --} -readDate :: String -> Maybe LocalTime -readDate s = - case (parse dateParser "" s) of - Left _ -> Nothing - Right x -> Just x - where - digit4 = count 4 digit - digit2 = count 2 digit - colon = char ':' - dateParser = do - year <- digit4 ; colon ; month <- digit2 ; colon ; day <- digit2 - space - hour <- digit2 ; colon ; minute <- digit2 - colon ; second <- digit2 - return $ - LocalTime - (fromGregorian (read year) (read month) (read day)) - (TimeOfDay (read hour) (read minute) - (fromIntegral ((read second) :: Integer))) - - -{- Format a Maybe CalendarTime into a "yyyy" string. Dates that are - Nothing in value format to "0000" --} -formatYear :: Maybe LocalTime -> String -formatYear Nothing = "0000" -formatYear (Just x) = formatTime defaultTimeLocale "%Y" x - - -{- Format a Maybe CalendarTime into a "yyyy-mm-dd" string. Dates that are - Nothing in value format to "0000-00-00" --} -formatDateHyphens :: Maybe LocalTime -> String -formatDateHyphens Nothing = "0000-00-00" -formatDateHyphens (Just x) = formatTime defaultTimeLocale "%Y-%m-%d" x - - -{- Format a Maybe CalendarTime into a "yyyymmdd" string. Dates that are - Nothing in value format to "00000000" --} -formatDate :: Maybe LocalTime -> String -formatDate Nothing = "00000000" -formatDate (Just x) = formatTime defaultTimeLocale "%Y%m%d" x - - -{- Format a Maybe CalendarTime into a "yyyymmdd-HHMMSS" string. Dates - that are Nothing in value format to "00000000-000000" --} -formatDateTime :: Maybe LocalTime -> String -formatDateTime Nothing = "00000000-000000" -formatDateTime (Just x) = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" x diff --git a/src/Photoname/DateFormat.hs b/src/Photoname/DateFormat.hs deleted file mode 100644 --- a/src/Photoname/DateFormat.hs +++ /dev/null @@ -1,34 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -module Photoname.DateFormat - ( buildDatePath - ) - where - -import System.FilePath -import Text.Printf - -import Photoname.Common -import Photoname.Date -import Photoname.Exif -import Photoname.Opts ( Options (..) ) - - -{- 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. --} -buildDatePath :: FilePath -> Ph FilePath -buildDatePath oldPath = do - dateString <- getDate oldPath - let date = readDate dateString - - suffix <- asks optSuffix - let fileName = printf "%s%s.jpg" (formatDateTime date) suffix - - parentDir <- asks optParentDir - noDirs <- asks optNoDirs - return $ if (noDirs) - then parentDir fileName - else parentDir (formatYear date) - (formatDateHyphens date) fileName diff --git a/src/Photoname/Exif.hs b/src/Photoname/Exif.hs deleted file mode 100644 --- a/src/Photoname/Exif.hs +++ /dev/null @@ -1,50 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -{-# LANGUAGE FlexibleContexts #-} - -module Photoname.Exif - where - -import Control.Exception -import Control.Monad.Except -import Graphics.Exif ( fromFile, getTag, Exif ) -import System.IO.Error - - -{- load Exif information from a filename, returning Nothing if libexif - encounters a NULL instead of raising an IO error. - - This is somewhat bogus because of the error type that is used by - the EXIF library. We have to compare the error string to see if it - is the kind of user error that we expect. If we build against an - EXIF library that raises some other exception, then this build will - still succeed, and the exception will be propagated instead of - transformed into a handled photoname error. --} -safeExif :: FilePath -> IO (Maybe Exif) -safeExif = try . fromFile >=> either handleBadExif (return . Just) - where - isBadExif e = - ioeGetErrorString e == "mkExif: NULL" && isUserError e - handleBadExif e = - if isBadExif e then return Nothing else ioError e - - -{- 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 = loadExif >=> getOneOf dateTagNames - where - loadExif = (liftIO . safeExif) >=> - maybe (throwError "Failed EXIF loading") return - - getOneOf [] _ = throwError "has no EXIF date" - getOneOf (tagName:tagNames) exif = - maybe (getOneOf tagNames exif) return =<< - liftIO (getTag exif tagName) - - dateTagNames = - ["DateTimeDigitized", "DateTimeOriginal", "DateTime"] diff --git a/src/Photoname/Opts.hs b/src/Photoname/Opts.hs deleted file mode 100644 --- a/src/Photoname/Opts.hs +++ /dev/null @@ -1,192 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - --- This is for GHC 7.8/7.10 compatibility with the --- Control.Applicative import below -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Photoname.Opts - ( Options (..) - , parseOpts, usageText - ) - where - -import Control.Applicative -import Data.Version ( showVersion ) -import Paths_photoname ( version ) -import System.Console.GetOpt -import System.Directory - - -data Options = Options - { optConfig :: String - , optHelp :: Bool - , optMove :: Bool - , optNoAction :: Bool - , optNoConfig :: Bool - , optNoDirs :: Bool - , optOldStyle :: Bool - , optParentDir :: String - , optQuiet :: Bool - , optSuffix :: String - } - -defaultConfig :: String -defaultConfig = "~/.config/photoname.conf" - -defaultOptions :: Options -defaultOptions = Options - { optConfig = defaultConfig - , optHelp = False - , optMove = False - , optNoAction = False - , optNoConfig = False - , optNoDirs = False - , optOldStyle = False - , optParentDir = "." - , optQuiet = False - , optSuffix = "" - } - - -options :: [OptDescr (Options -> Options)] -options = - [ Option ['c'] ["config"] - (ReqArg (\c opts -> opts { optConfig = c }) "FILE") - ("Defaults to " ++ defaultConfig ++ ". See CONFIG") - , Option ['C'] ["no-config"] - (NoArg (\opts -> opts { optNoConfig = True } )) - "Do not load config file" - , Option ['D'] ["no-dirs"] - (NoArg (\opts -> opts { optNoDirs = True } )) - "No subdirectory hierarchy. Just do DIR/NEWFILE" - , Option ['h'] ["help"] - (NoArg (\opts -> opts { optHelp = True } )) - "This help text" - , Option [] ["move"] - (NoArg (\opts -> opts { optMove = True } )) - "Move the files, don't just hard-link to the new locations" - , Option ['n'] ["no-action"] - (NoArg (\opts -> opts { optNoAction = True } )) - "Display what would be done, but do nothing" - , Option ['o'] ["old-style"] - (NoArg (\opts -> opts { optOldStyle = True } )) - "Use older name format with serial. See FILENAME FORMAT" - , Option ['p'] ["parent-dir"] - (ReqArg (\d opts -> opts { optParentDir = d } ) "DIR") - "Top-level directory where new links are created. Default: ." - , Option ['q'] ["quiet"] - (NoArg (\opts -> opts { optQuiet = True } )) - "Suppress normal output of what's being done" - , Option ['s'] ["suffix"] - (ReqArg (\s opts -> opts { optSuffix = s } ) "SUF") - "Add optional suffix to each name. See SUFFIX" - ] - - -{- Try to load a config file, converting its lines into a [String] - of long options to be parsed --} -loadConfig :: FilePath -> IO [String] -loadConfig path = do - confExists <- doesFileExist path - - if confExists - then (map ("--" ++) . lines) <$> readFile path - else return [] - - -{- Perform the actual parse of a [String] --} -parseOpts' :: [String] -> IO (Options, [String]) -parseOpts' args = - case getOpt Permute options args of - (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) - (_,_,errs) -> ioError $ userError (concat errs ++ usageText) - - -{- The set of steps to parse args from both the command-line and a - config file --} -parseOpts :: [String] -> IO (Options, [String]) -parseOpts cliArgs = do - -- Parse argv first time to get -c and/or -C - (prelimOpts, _) <- parseOpts' cliArgs - - -- Load config file - confArgs <- if (optNoConfig prelimOpts) - then return [] - else loadConfig $ optConfig prelimOpts - - -- Parse second time with all args - parseOpts' (confArgs ++ cliArgs) - - -usageText :: String -usageText = (usageInfo header options) ++ "\n" ++ footer - where - header = init $ unlines - [ "Usage: photoname [OPTIONS] FILES" - , "Rename and move photo files based on EXIF data" - , "" - , "Options:" - ] - footer = init $ unlines - [ "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 and optionally some other information." - , "" - , "CONFIG" - , "" - , "The program will attempt to load a config file from this location: " ++ defaultConfig ++ " A different path may be specified with the --config switch" - , "Entries in this file should be the long switches above minus the -- and including any arguments they may have. To completely ignore an existing config file, use the --no-config switch." - , "" - , "Example config contents:" - , "" - , " move" - , " old-style" - , " parent-dir=~/mypics" - , " suffix=_dwm" - , "" - , "" - , "FILENAME FORMAT" - , "" - , "Normal operation builds 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, named as follows:" - , "" - , "A photo shot on 2002-May-02 01:23:07 PM:" - , " img_1790.jpg -> /2002/2002-05-02/20020502-132307.jpg" - , "" - , "The EXIF date/time stamp used for naming is the first of these fields to be found: Exif.Photo.DateTimeDigitized, Exif.Photo.DateTimeOriginal, Exif.Image.DateTime" - , "" - , "The is the one given by the --parent-dir switch and represents the top-level of where you're storing photos." - , "" - , "The --no-dirs switch will suppress the directory-hierarchy-creating part of this, instead placing the new links directly in . So you get files like:" - , "" - , " /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 not leave the original links." - , "" - , "The --old-style switch specifies the prior behavior of photoname where the name is a date followed by the last three digits of the camera-assigned number from the original filename:" - , "" - , " img_1790.jpg -> /2002/2002-05-02/20020502_790.jpg" - , "" - , "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. Examples of the two that I have:" - , "" - , " vvv (use these digits)" - , " Panasonic: P###0###.jpg" - , " Canon: img_####.jpg" - , " ^^^" - , " ^^^" - , "" - , "The --old-style behavior in photoname remains for backwards compatibility. Many cameras today (and particularly camera phones) don't generate a name we can use in this way, and so something needed to change in this software." - , "" - , "Another nagging problem is the old-style naming is non-deterministic. Using photoname --old-style on a file may not always give you the same name, say if the serial info in the name is ever lost. Naming based on the EXIF data alone is more reliable." - , "" - , "" - , "SUFFIX" - , "" - , "The optional --suffix switch can be used to provide a string placed between the date/time and extension. Use it for anything you like. An example is photographer initials or series info. Example:" - , "" - , "photoname invoked with --suffix=_dwm :" - , " 20020502-132307_dwm.jpg" - , "" - , "Version " ++ (showVersion version) ++ " Dino Morelli " - ] diff --git a/src/Photoname/SerialFormat.hs b/src/Photoname/SerialFormat.hs deleted file mode 100644 --- a/src/Photoname/SerialFormat.hs +++ /dev/null @@ -1,69 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -module Photoname.SerialFormat - ( buildSerialPath - ) - where - -import System.FilePath -import Text.ParserCombinators.Parsec - -import Photoname.Common -import Photoname.Date -import Photoname.Exif -import Photoname.Opts ( Options (..) ) - - -{- 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 - scan = do { end } -- If end succeeds, return that. - <|> - do { p; scan } -- Otherwise, match p and recurse. - - -serialNum :: GenParser Char st [Char] -serialNum = - skipTill anyChar $ try $ do -- Skip anything up to.. - serial <- count 3 digit -- 3 digits.. - char '.' -- followed by a period.. - count 3 alphaNum -- followed by 3 alphaNumS.. - eof -- at the end of the string. - 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 :: (MonadError String m) => String -> m String -getSerial path = - case (parse serialNum "" path) of - Left _ -> throwError "Can't determine serial" - Right serial -> return serial - - -{- 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. --} -buildSerialPath :: FilePath -> Ph FilePath -buildSerialPath oldPath = do - dateString <- getDate oldPath - serial <- getSerial oldPath - let date = readDate dateString - - suffix <- asks optSuffix - let fileName = (formatDate date) ++ "_" ++ serial - ++ suffix <.> "jpg" - - parentDir <- asks optParentDir - noDirs <- asks optNoDirs - return $ if (noDirs) - then parentDir fileName - else parentDir (formatYear date) - (formatDateHyphens date) fileName diff --git a/src/app/Photoname/Opts.hs b/src/app/Photoname/Opts.hs new file mode 100644 --- /dev/null +++ b/src/app/Photoname/Opts.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} + +module Photoname.Opts + ( parseOpts + ) + where + +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 Photoname.Common + ( Artist (..) + , ConfigPath (..) + , CopySwitch (..) + , MoveSwitch (..) + , NoActionSwitch (..) + , NoDirsSwitch (..) + , Options (..) + , ParentDir (..) + , Prefix (..) + , Suffix (..) + , Verbosity (Verbose) + , readVerbosity + ) + + +parser :: Parser Options +parser = Options + <$> optional ( option (maybeReader $ Just . Artist) + ( long "artist" + <> short 'a' + <> metavar "ARTIST" + <> help "Set artist info in the Exif.Image.Artist tag. Requires exiv2. See ARTIST" + ) + ) + <*> optional ( option (maybeReader $ Just . ConfigPath) + ( long "config" + <> short 'c' + <> metavar "FILE" + <> help "Path to a config file. See CONFIG" + ) + ) + <*> ( CopySwitch <$> switch + ( long "copy" + <> help "Copy files instead of hard linking, even if on the same filesystem" + ) + ) + <*> ( NoDirsSwitch <$> switch + ( long "no-dirs" + <> short 'D' + <> help "No subdirectory hierarchy. Just do DIR/NEWFILE" + ) + ) + <*> ( MoveSwitch <$> switch + ( long "move" + <> help "Move the files, don't just hard-link to the new locations. In other words, remove the source path." + ) + ) + <*> ( NoActionSwitch <$> switch + ( long "no-action" + <> short 'n' + <> help "Display what would be done, but do nothing" + ) + ) + <*> ( ParentDir <$> strOption + ( long "parent-dir" + <> short 'p' + <> metavar "DIR" + <> help "Top-level directory where new links are created." + <> showDefault + <> value "." + ) + ) + <*> ( Prefix <$> strOption + ( long "prefix" + <> short 'P' + <> metavar "PRE" + <> help "Add optional prefix to each name. See PREFIX" + <> value "" + ) + ) + <*> ( Suffix <$> strOption + ( long "suffix" + <> short 's' + <> metavar "SUF" + <> help "Add optional suffix to each name. See SUFFIX" + <> value "" + ) + ) + <*> option (eitherReader readVerbosity) + ( long "verbose" + <> short 'v' + <> metavar "NUM" + <> help "Verbosity level. 0=quiet, 1=normal messages, 2=more info, 3=debug" + <> showDefault + <> value (Verbose INFO) + ) + <*> ( some $ strArgument + $ metavar "FILES..." + ) + + +{- Try to load a config file, converting its lines into a [String] + of long options to be parsed +-} +loadConfig :: ConfigPath -> IO [String] +loadConfig (ConfigPath path) = do + confExists <- doesFileExist path + + if confExists + then (map ("--" ++) . lines) <$> readFile path + else do + hPutStrLn stderr $ "Config file " <> path <> " does not exist!" + exitFailure + + +versionHelper :: String -> Parser (a -> a) +versionHelper progName = + infoOption (printf "%s %s" progName (showVersion version)) $ mconcat + [ long "version" + , help "Show version information" + , hidden + ] + + +parseOpts :: IO Options +parseOpts = do + -- Parse command-line args first to get -c + cliOpts <- parseOpts' =<< getArgs + + case optConfig cliOpts of + Just configPath -> do + confArgs <- loadConfig configPath + parseOpts' $ confArgs <> (optPaths cliOpts) + Nothing -> pure cliOpts + + +parseOpts' :: [String] -> IO Options +parseOpts' args = do + pn <- getProgName + handleParseResult $ execParserPure + defaultPrefs + ( info (parser <**> helper <**> versionHelper pn) + ( header (printf "%s - Rename and move photo files based on EXIF data" pn) + <> footer' + ) + ) + args + + +footer' :: InfoMod a +footer' = footerDoc . Just . string $ printf content (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. + +FILENAME FORMAT + +Normal operation builds 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, named as follows: + +A photo shot on 2002-May-02 01:23:07 PM: + img_1790.jpg -> /2002/2002-05-02/20020502-132307.jpg + +The EXIF date/time stamp used for naming is the first of these fields to be found: Exif.Photo.DateTimeOriginal, Exif.Photo.DateTimeDigitized, Exif.Image.DateTime + +If none of the EXIF tags listed above is found, the program will try to gather date/time info from the filename itself. Filenames that are parsable look like: + + some/directory/foo2021-10-04-172949.jpg + some/directory/foo2021-10-04-17-29-49-942.jpg + +In the event the date/time info is gathered from the filename, the program will go ahead and write this into the file's EXIF tags. BEWARE: Unless you're using the --copy switch, this WILL MODIFY THE ORIGINAL FILES! + +The EXIF modifications rely on the system having the `exiv2` binary installed and on the path. Without this, some of photoname's functions will fail including: setting the date from the filename and setting the artist info. + +The is the one given by the -p|--parent-dir switch and represents the top-level of where you're storing photos. + +The -D|--no-dirs switch will suppress the directory-hierarchy-creating part of this, instead placing the new links directly in . So you get files like: + + /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. + +ARTIST + +Set artist info in the Exif.Image.Artist tag. This can be any string you like but good conventional ones would look like: + + 'Role1, Name1[; Role2, Name2;...]' + + 'Photographer, Roscoe Jones' + 'Camera owner, Ren Hoek; Photographer, Stimpson J Cat' + +Be careful with what you put in here, we've seen problems with email addresses rendering the entire field not visible in some applications. Keep it simple as above! + +Pass a quoted empty string to -a|--artist to delete an existing Artist tag, like this: -a '' or --artist='' + +PREFIX + +The optional -P|--prefix switch can be used to provide a string placed at the beginning of the new filename, before the date. Use it for anything you like. An example is subject matter. Example: + +photoname invoked with --prefix=BirthdayParty_ : + BirthdayParty_20020502-132307.jpg + +SUFFIX + +The optional -s|--suffix switch can be used to provide a string placed between the date/time and extension. Use it for anything you like. An example is photographer initials or edit info. Example: + +photoname invoked with --suffix=_dwm : + 20020502-132307_dwm.jpg + +photoname invoked with --suffix=_sd1920x1080 (Sized for Desktop 1920x1080) : + 20020502-132307_sd1920x1080.jpg + +photoname invoked with --suffix=_BirthdayParty : + 20020502-132307_BirthdayParty.jpg + +CONFIG + +If the -c|--config switch is used the program will attempt to load a config file from the supplied path +Entries in this file should be the long switches above minus the -- and including any arguments they may have. If a config file is used, all other command-line switches are ignored. + +Example config contents: + + move + parent-dir=~/mypics + suffix=_dwm + +Version %s Dino Morelli |] diff --git a/src/app/photoname.hs b/src/app/photoname.hs new file mode 100644 --- /dev/null +++ b/src/app/photoname.hs @@ -0,0 +1,60 @@ +import Control.Monad ( filterM, forM_, when ) +import Control.Newtype.Generics ( op ) +import System.Posix ( getFileStatus, isRegularFile ) +import Text.Printf ( printf ) + +import Photoname.Common ( CopySwitch (..), 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.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 + ] + + +processFile :: SrcPath -> Ph () +processFile srcPath = do + imageDate <- acquireDate srcPath + destPath <- createNewLink imageDate srcPath + setExifDate imageDate destPath + setArtist destPath + + +-- Figure out and execute what the user wants based on the supplied args. +main :: IO () +main = do + opts <- parseOpts + + initLogging $ optVerbosity opts + + -- Get rid of anything not a regular file from the list of paths + actualPaths <- map SrcPath <$> filterM + (\p -> getFileStatus p >>= pure . isRegularFile) (optPaths 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 (op CopySwitch . optCopy $ opts) $ + infoM lname "Copy has been specified instead of the default of hard linking." + + when (op MoveSwitch . optMove $ opts) $ + infoM lname "Removing original links after new links are in place." + + -- Do the link manipulations, and report any errors. + forM_ actualPaths $ \srcPath -> do + result <- runRename opts $ processFile srcPath + either (\em -> errorM lname $ printf "** Processing %s: %s\n" (op SrcPath srcPath) em) + (const 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 new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/Common.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Photoname.Common + ( Artist (..) + , ConfigPath (..) + , CopySwitch (..) + , DestPath (..) + , MoveSwitch (..) + , NoActionSwitch (..) + , NoDirsSwitch (..) + , ParentDir (..) + , Options (..) + , Ph + , Prefix (..) + , SrcPath (..) + , Suffix (..) + , Verbosity (..) + , readVerbosity + , runRename + + -- Re-exporting: + , MonadError + , ask, asks + , liftIO + , throwError + ) + 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 (..) ) + + +data Verbosity + = Quiet + | Verbose Priority + +instance Show Verbosity where + show Quiet = "0" + show (Verbose NOTICE) = "1" + show (Verbose INFO) = "2" + show (Verbose DEBUG) = "3" + show _ = "Should never see this, invalid verbosity level being shown" + +readVerbosity :: String -> Either String Verbosity +readVerbosity "0" = Right Quiet +readVerbosity "1" = Right $ Verbose NOTICE +readVerbosity "2" = Right $ Verbose INFO +readVerbosity "3" = Right $ Verbose DEBUG +readVerbosity _ = Left "Invalid verbosity level, expecting 0-3" + + +newtype Artist = Artist String + +newtype ConfigPath = ConfigPath FilePath + +newtype CopySwitch = CopySwitch Bool + deriving Generic + +instance Newtype CopySwitch + +newtype NoDirsSwitch = NoDirsSwitch Bool + deriving Generic + +instance Newtype NoDirsSwitch + +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 Prefix = Prefix String + deriving Generic + +instance Newtype Prefix + +newtype Suffix = Suffix String + deriving Generic + +instance Newtype Suffix + +data Options = Options + { optArtist :: Maybe Artist + , optConfig :: Maybe ConfigPath + , optCopy :: CopySwitch + , optNoDirs :: NoDirsSwitch + , optMove :: MoveSwitch + , optNoAction :: NoActionSwitch + , optParentDir :: ParentDir + , optPrefix :: Prefix + , optSuffix :: Suffix + , optVerbosity :: Verbosity + , optPaths :: [FilePath] + } + + +newtype SrcPath = SrcPath FilePath + deriving Generic + +instance Newtype SrcPath + +newtype DestPath = DestPath FilePath + deriving Generic + +instance Newtype DestPath + + +type Ph a = ReaderT Options (ExceptT String IO) a + + +runRename :: Options -> Ph a -> IO (Either String a) +runRename env action = runExceptT $ runReaderT action env diff --git a/src/lib/Photoname/CopyLink.hs b/src/lib/Photoname/CopyLink.hs new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/CopyLink.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE 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 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 ) + + +createNewLink :: PhDate -> SrcPath -> Ph DestPath +createNewLink imageDate srcPath@(SrcPath srcFp) = do + opts <- ask + destPath@(DestPath destFp) <- case imageDate of + ExifDate lt -> buildDatePath lt + FilenameDate lt -> buildDatePath lt + NoDateFound -> throwError "Could not extract any date information" + + -- Check for existance of the target file + exists <- liftIO $ fileExist destFp + when exists $ throwError $ "Destination " ++ destFp ++ " exists!" + + -- Display what will be done + liftIO $ noticeM lname $ srcFp ++ " -> " ++ destFp + + unless (op NoActionSwitch . optNoAction $ opts) $ do + -- Make the target dir + liftIO $ createDirectoryIfMissing True $ takeDirectory destFp + + -- Make the new file + if (op CopySwitch . optCopy $ opts) + then liftIO $ copyFile srcFp destFp + else tryHardLink srcPath destPath + + -- If user has specified, remove the original link + when (op MoveSwitch . optMove $ opts) $ + liftIO $ removeLink srcFp + + pure destPath + + +tryHardLink :: SrcPath -> DestPath -> Ph () +tryHardLink (SrcPath srcFp) (DestPath destFp) = do + ei <- liftIO $ try $ createLink srcFp destFp + either failureHandler pure ei + where + failureHandler :: IOException -> Ph () + failureHandler _ = do + liftIO $ warningM lname "Hard link failed, attempting to copy instead" + liftIO $ copyFile srcFp destFp + + +{- Construct the destination file path based on the information we have (parent + 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 + + parentFp <- asks (op ParentDir . optParentDir) + noDirs <- asks (op NoDirsSwitch . optNoDirs) + pure . DestPath $ if (noDirs) + then parentFp fileName + else parentFp (formatYear date) + (formatDateHyphens date) fileName diff --git a/src/lib/Photoname/Date.hs b/src/lib/Photoname/Date.hs new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/Date.hs @@ -0,0 +1,139 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +{-# LANGUAGE FlexibleContexts #-} + +module Photoname.Date + ( PhDate (..) + , formatYear, formatDateHyphens, formatDate, formatDateTime + , formatDateForExif + , 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 Photoname.Common ( SrcPath (..) ) + + +data PhDate + = ExifDate LocalTime + | FilenameDate LocalTime + | NoDateFound + deriving (Eq, Show) + +instance Semigroup PhDate where + (<>) e@(ExifDate _) _ = e + (<>) (FilenameDate _) e@(ExifDate _) = e + (<>) f@(FilenameDate _) _ = f + (<>) NoDateFound x = x + +instance Monoid PhDate where + mempty = NoDateFound + + +-- Parsec helper defs + +colon :: ParsecT String u Identity Char +colon = char ':' + +digit2, digit4 :: ParsecT String u Identity [Char] +digit2 = count 2 digit +digit4 = count 4 digit + + +{- 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 + returned as Nothing +-} +parseExifDate :: Maybe String -> PhDate +parseExifDate Nothing = NoDateFound +parseExifDate (Just s) = + case (parse dateParser "" s) of + Left _ -> NoDateFound + Right x -> ExifDate x + where + dateParser = do + year <- digit4 ; colon ; month <- digit2 ; colon ; day <- digit2 + space + hour <- digit2 ; colon ; minute <- digit2 + colon ; second <- digit2 + pure $ + LocalTime + (fromGregorian (read year) (read month) (read day)) + (TimeOfDay (read hour) (read minute) + (fromIntegral ((read second) :: Integer))) + + +{- Parse a string in one of the the forms below into a CalendarTime datatype. + + /some/path/ANYTHINGyyyy-mm-dd-hhmmss.jpg + /some/path/ANYTHINGyyyy-mm-dd-hh-mm-ss-ttt.jpg + ANYTHINGyyyy-mm-dd-hhmmss.jpg + ANYTHINGyyyy-mm-dd-hh-mm-ss-ttt.jpg + yyyymmdd-hhmmss.jpg + yyyymmdd-hhmmss_xyz.jpg + PXL_yyyymmdd_hhmmssttt.jpg + PXL_yyyymmdd_hhmmssttt_xyz.jpg +-} +parseFilenameDate :: SrcPath -> PhDate +parseFilenameDate srcPath = + case (parse dateParser "" (takeFileName . op SrcPath $ srcPath)) of + Left _ -> NoDateFound + Right x -> FilenameDate x + where + dateParser = do + manyTill anyChar (try $ lookAhead digit4) + year <- digit4 + manyTill anyChar (try $ lookAhead digit2) + month <- digit2 + manyTill anyChar (try $ lookAhead digit2) + day <- digit2 + manyTill anyChar (try $ lookAhead digit2) + hour <- digit2 + manyTill anyChar (try $ lookAhead digit2) + minute <- digit2 + manyTill anyChar (try $ lookAhead digit2) + second <- digit2 + pure $ + LocalTime + (fromGregorian (read year) (read month) (read day)) + (TimeOfDay (read hour) (read minute) + (fromIntegral ((read second) :: Integer))) + + +{- Format a Maybe CalendarTime into a "yyyy" string +-} +formatYear :: LocalTime -> String +formatYear = formatTime defaultTimeLocale "%Y" + + +{- Format a Maybe CalendarTime into a "yyyy-mm-dd" string +-} +formatDateHyphens :: LocalTime -> String +formatDateHyphens = formatTime defaultTimeLocale "%Y-%m-%d" + + +{- Format a Maybe CalendarTime into a "yyyymmdd" string +-} +formatDate :: LocalTime -> String +formatDate = formatTime defaultTimeLocale "%Y%m%d" + + +{- Format a Maybe CalendarTime into a "yyyymmdd-HHMMSS" string +-} +formatDateTime :: LocalTime -> String +formatDateTime = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" + + +{- Format a Maybe CalendarTime into a "yyyy:mm:dd HH:MM:SS" string +-} +formatDateForExif :: LocalTime -> String +formatDateForExif = formatTime defaultTimeLocale "%Y:%m:%d %H:%M:%S" diff --git a/src/lib/Photoname/Exif.hs b/src/lib/Photoname/Exif.hs new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/Exif.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Photoname.Exif + ( getExifDate + ) + where + +import Control.Monad.Except ( MonadIO, liftIO ) +import Control.Newtype.Generics ( ala ) +import qualified Data.Map as M +import Data.Monoid ( First (..) ) +import Graphics.HsExif ( ExifTag, ExifValue, dateTime, dateTimeDigitized, + dateTimeOriginal, parseFileExif ) + +import Photoname.Common ( SrcPath (..) ) + + +{- + Load EXIF information from filepath, or evaluate to Nothing +-} + +getExifDate :: MonadIO m => SrcPath -> m (Maybe String) +getExifDate (SrcPath fp) = liftIO $ extractDate <$> parseFileExif fp + + +{- + Extract the date from the passed in EXIF data, if we got any from the file. + Evaluate to Nothing if we can't locate a date at all. +-} + +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] ) diff --git a/src/lib/Photoname/Exiv2.hs b/src/lib/Photoname/Exiv2.hs new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/Exiv2.hs @@ -0,0 +1,54 @@ +module Photoname.Exiv2 + ( setArtist + , setExifDate + ) + where + +import Control.Monad ( unless ) +import Control.Newtype.Generics ( op ) +import System.Process ( callCommand ) +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 ) + + +newtype Command = Command { unCommand :: String } + + +execCommands :: [Command] -> Ph () +execCommands commands = do + opts <- ask + + -- Display what will be done + liftIO $ mapM_ (noticeM lname . unCommand) commands + + -- Execute the commands + unless (op NoActionSwitch . optNoAction $ opts) $ + liftIO $ mapM_ (callCommand . unCommand) commands + + pure () + + +setArtist :: DestPath -> Ph () +setArtist (DestPath destFp) = do + opts <- ask + + case optArtist opts 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 ] + + +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 + ] + +setExifDate _ _ = pure () diff --git a/src/lib/Photoname/Log.hs b/src/lib/Photoname/Log.hs new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/Log.hs @@ -0,0 +1,45 @@ +module Photoname.Log + ( initLogging + , lname + , logTest + + -- Re-exported from System.Log + , debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM + ) + where + +import System.IO ( Handle, stdout ) +import System.Log.Handler.Simple ( GenericHandler, streamHandler ) +import System.Log.Logger + +import Photoname.Common ( Verbosity (Quiet, Verbose) ) + + +lname :: String +lname = rootLoggerName + + +initLogging :: Verbosity -> IO () +initLogging verbosity = do + updateGlobalLogger lname . setHandlers =<< handlers verbosity + case verbosity of + Quiet -> pure () + Verbose loggerLevel -> updateGlobalLogger lname $ setLevel loggerLevel + + +handlers :: Verbosity -> IO [GenericHandler Handle] +handlers Quiet = pure [] +handlers (Verbose _) = sequence [streamHandler stdout DEBUG] + + +-- Test function to generate every kind of log message +logTest :: IO () +logTest = do + debugM lname "log test message DEBUG 1 of 8" + infoM lname "log test message INFO 2 of 8" + noticeM lname "log test message NOTICE 3 of 8" + warningM lname "log test message WARNING 4 of 8" + errorM lname "log test message ERROR 5 of 8" + criticalM lname "log test message CRITICAL 6 of 8" + alertM lname "log test message ALERT 7 of 8" + emergencyM lname "log test message EMERGENCY 8 of 8" diff --git a/src/photoname.hs b/src/photoname.hs deleted file mode 100644 --- a/src/photoname.hs +++ /dev/null @@ -1,86 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -{-# LANGUAGE FlexibleContexts #-} - -import Control.Monad ( filterM, forM_, unless, when ) -import System.Directory ( createDirectoryIfMissing ) -import System.Environment ( getArgs ) -import System.FilePath ( takeDirectory ) -import System.Posix ( createLink, fileExist, getFileStatus, - isRegularFile, removeLink ) -import Text.Printf ( printf ) - -import Photoname.Common ( Ph, ask, liftIO, runRename, throwError ) -import Photoname.Opts ( Options (..) , parseOpts, usageText ) -import Photoname.DateFormat ( buildDatePath ) -import Photoname.SerialFormat ( buildSerialPath ) - - -{- Take a file path to a JPEG file and use EXIF information available to - link the file at its new location below the given basedir. --} -createNewLink :: FilePath -> Ph () -createNewLink oldPath = do - opts <- ask - newPath <- if (optOldStyle opts) - then buildSerialPath oldPath - else buildDatePath oldPath - - -- Check for existance of the target file - exists <- liftIO $ fileExist newPath - when exists $ throwError $ "Destination " ++ newPath ++ " exists!" - - -- Display what will be done - unless (optQuiet opts) $ - liftIO $ putStrLn $ oldPath ++ " -> " ++ newPath - - unless (optNoAction opts) $ do - -- Make the target dir - liftIO $ createDirectoryIfMissing True $ 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 () - - --- Figure out and execute what the user wants based on the supplied args. -executeCommands :: Options -> [String] -> IO () - --- User gave no files at all. Display help -executeCommands _ [] = putStrLn usageText - --- Normal program operation, process the files with the args. -executeCommands opts filePaths = do - -- Get rid of anything not a regular file from the list of paths - actualPaths <- filterM - (\p -> getFileStatus p >>= return . isRegularFile) filePaths - - -- Notify user of the switches that will be in effect. - when (optNoAction opts) $ - putStrLn "No-action mode, nothing will be changed." - - when (optMove opts) $ - putStrLn "Removing original links after new links are in place." - - -- Do the link manipulations, and report any errors. - forM_ actualPaths $ \path -> do - result <- runRename opts $ createNewLink path - either (\em -> printf "** Processing %s: %s\n" path em) - (const return ()) result - - -main :: IO () -main = do - -- Parse the arguments - (opts, paths) <- getArgs >>= parseOpts - - -- Do the photo naming procedure - executeCommands opts paths - - -- Perhaps we should get an ExitCode back from all this above? diff --git a/src/tests/Test/Photoname/Date.hs b/src/tests/Test/Photoname/Date.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/Photoname/Date.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Photoname.Date + ( tests + ) + where + +import Data.Time.Calendar +import Data.Time.LocalTime +import Photoname.Common ( SrcPath (..) ) +import Photoname.Date ( PhDate (..), parseExifDate, parseFilenameDate ) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + + +expectedLocalTime :: LocalTime +expectedLocalTime = LocalTime (fromGregorian 2021 10 04) + (TimeOfDay 17 29 (fromIntegral (49 :: Integer))) + + +tests :: TestTree +tests = testGroup "Photoname.Date" + [ parsingTests + , propsPhDate + ] + + +parsingTests :: TestTree +parsingTests = testGroup "parsing tests" + [ testCase "parse a datetime in EXIF format" $ + ExifDate expectedLocalTime @=? + (parseExifDate $ Just "2021:10:04 17:29:49") + , testCase "parse a date from a file path with directories" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "some/directory/signal-2021-10-04-172949.jpg") + , testCase "parse a date from a file path with directories and more hyphens" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "some/directory/signal-2021-10-04-17-29-49-942.jpg") + , testCase "parse a date from a file path with no directories" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "signal-2021-10-04-172949.jpg") + , testCase "parse a date from a file path with more hyphens but no directories" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "signal-2021-10-04-17-29-49-942.jpg") + , testCase "parse a date from a previously-named file path" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "20211004-172949.jpg") + , testCase "parse a date from a previously-named file path with suffix" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "20211004-172949_xyz.jpg") + , testCase "parse a date from a Pixel phone path file path" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "PXL_20211004_172949000.jpg") + , testCase "parse a date from a Pixel phone path file path with extra suffix" $ + FilenameDate expectedLocalTime @=? + parseFilenameDate (SrcPath "PXL_20211004_172949000_foo.jpg") + ] + + +instance Arbitrary PhDate where + arbitrary = do + oneof + [ pure $ ExifDate expectedLocalTime + , pure $ FilenameDate expectedLocalTime + , pure NoDateFound + ] + +propsPhDate :: TestTree +propsPhDate = testGroup "testing the Semigroup and Monoid properties of PhDate" + [ testProperty "Semigroup associativity x <> (y <> z) == (x <> y) <> z" $ + \(x :: PhDate) (y :: PhDate) (z :: PhDate) -> + x <> (y <> z) == (x <> y) <> z + , testProperty "Monoid right identity x <> mempty == x" $ + \(x :: PhDate) -> x <> mempty == x + , 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 + ] diff --git a/src/tests/TestLink.hs b/src/tests/TestLink.hs new file mode 100644 --- /dev/null +++ b/src/tests/TestLink.hs @@ -0,0 +1,340 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module TestLink + ( tests + ) + 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 Test.Tasty +import Test.Tasty.HUnit +import qualified Util + + +parentDir, oldPath, newLinkPathDate :: FilePath + +parentDir = Util.resourcesPath "testParentDir" +oldPath = Util.resourcesPath "dateTimeDigitized.jpg" +newLinkPathDate = parentDir "2003/2003-09-02/20030902-114303.jpg" + + +tests :: TestTree +tests = testGroup "test the normal behavior of hard-linking original files to new paths" + [ testLinkDigitized + , testLinkOriginal + , testLinkDate + , testNoDate + , testMove + , testLinkNoAction + , testLinkNoActionLong + , testLinkQuiet + , testLinkQuietLong + , testLinkSuffix + , testLinkPrefix + , testNoExif + , testNotAnImage + , testDirForFile + , testLinkFilenameDate + ] + + +testLinkDigitized :: TestTree +testLinkDigitized = testCase "tests for DateTimeDigitized" $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, oldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPathDate + assertBool "make link, date digitized: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist oldPath + assertBool "make link, date digitized: existance of old link" existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + assertBool "make link, date digitized: correct output" + (output =~ newLinkPathDate :: Bool) + + +testLinkOriginal :: TestTree +testLinkOriginal = testCase "tests for DateTimeOriginal" $ do + let digitizedOldPath = Util.resourcesPath "dateTimeOriginal.jpg" + + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, digitizedOldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPathDate + assertBool "make link, date original: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist digitizedOldPath + assertBool "make link, date original: existance of old link" existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + assertBool "make link, date original: correct output" + (output =~ newLinkPathDate :: Bool) + + +testLinkDate :: TestTree +testLinkDate = testCase "tests for DateTime" $ do + let dateOldPath = Util.resourcesPath "dateTime.jpg" + let customLinkPathDate = parentDir "2019/2019-03-26/20190326-075309.jpg" + + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, dateOldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist customLinkPathDate + assertBool "make link, date: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist dateOldPath + assertBool "make link, date: existance of old link" existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + assertBool "make link, date: correct output" + (output =~ customLinkPathDate :: Bool) + + +testNoDate :: TestTree +testNoDate = testCase "test for no date in the file" $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, Util.resourcesPath "noDate.jpg" ] + waitForProcess procH + + -- Test output to stdout + assertBool "no EXIF: correct output" + (output =~ "\\*\\* Processing util/resources/test/noDate.jpg: Could not extract any date information" :: Bool) + + +testMove :: TestTree +testMove = testCase "tests to ensure the file is moved (original link removed)" $ do + -- Make a dummy copy of the source file. This test will be getting rid + -- of it, if successful. + let newOldPath = Util.resourcesPath "moveTest.jpg" + copyFile oldPath newOldPath + + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--move", "--parent-dir=" ++ parentDir, newOldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPathDate + assertBool "move file: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist newOldPath + Util.assertFalse "move file: existance of old link" existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + assertBool "move file: correct output" + (output =~ newLinkPathDate :: Bool) + + +testLinkNoAction :: TestTree +testLinkNoAction = testLinkNoAction' "no action" "-n" + + +testLinkNoActionLong :: TestTree +testLinkNoActionLong = testLinkNoAction' "no action long" "--no-action" + + +testLinkNoAction' :: String -> String -> TestTree +testLinkNoAction' label switch = testCase label $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ switch, "--parent-dir=" ++ parentDir, oldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist parentDir + Util.assertFalse (label ++ ": existance of new link") existsNew + + -- Check that old path still exists + existsOld <- fileExist oldPath + assertBool (label ++ ": existance of old link") existsOld + + -- Test output to stdout + assertBool (label ++ ": correct output") + (output =~ newLinkPathDate :: Bool) + + +testLinkQuiet :: TestTree +testLinkQuiet = testLinkQuiet' "make link quiet" "-v0" + + +testLinkQuietLong :: TestTree +testLinkQuietLong = testLinkQuiet' "make link quiet long" "--verbose 0" + + +-- Reusable test code for above short/long versions of the quiet switch +testLinkQuiet' :: String -> String -> TestTree +testLinkQuiet' label switch = testCase label $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ switch, "--parent-dir=" ++ parentDir, oldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPathDate + assertBool (label ++ ": existance of new link") existsNew + + -- Check that old path still exists + existsOld <- fileExist oldPath + assertBool (label ++ ": existance of old link") existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + Util.assertFalse (label ++ ": no output") + (output =~ newLinkPathDate :: Bool) + + +testLinkSuffix :: TestTree +testLinkSuffix = testCase "test link with a suffix" $ do + let suffix = "_dwm" + + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, "--suffix=" ++ suffix, oldPath ] + waitForProcess procH + + let newLinkPath = parentDir + ("2003/2003-09-02/20030902-114303" ++ suffix) <.> "jpg" + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPath + assertBool "make link: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist oldPath + assertBool "make link: existance of old link" existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + assertBool "make link: correct output" + (output =~ newLinkPath :: Bool) + + +testLinkPrefix :: TestTree +testLinkPrefix = testCase "test link with a prefix" $ do + let prefix = "SomeSubject_" + + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, "--prefix=" ++ prefix, oldPath ] + waitForProcess procH + + let newLinkPath = parentDir + ("2003/2003-09-02/" <> prefix <> "20030902-114303") <.> "jpg" + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPath + assertBool "make link: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist oldPath + assertBool "make link: existance of old link" existsOld + + -- Remove files and dirs that were created + removeDirectoryRecursive parentDir + + -- Test output to stdout + assertBool "make link: correct output" + (output =~ newLinkPath :: Bool) + + +testNoExif :: TestTree +testNoExif = testCase "test for a file without any EXIF data" $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, Util.resourcesPath "noExif.jpg" ] + waitForProcess procH + + -- Test output to stdout + assertBool "no EXIF: correct output" + (output =~ "\\*\\* Processing util/resources/test/noExif.jpg: Could not extract any date information" :: Bool) + + +testNotAnImage :: TestTree +testNotAnImage = testCase "test for a file that isn't an image" $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, Util.resourcesPath "notAnImage.txt" ] + waitForProcess procH + + -- Test output to stdout + assertBool "no EXIF: correct output" + (output =~ "\\*\\* Processing util/resources/test/notAnImage.txt: Could not extract any date information" :: Bool) + + +testDirForFile :: TestTree +testDirForFile = testCase "test when a directory is passed instead of a file" $ do + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, Util.resourcesPath ] + waitForProcess procH + + -- Test output to stdout + assertBool "dir as file to change: correct output" + (output =~ "" :: Bool) + + +testLinkFilenameDate :: TestTree +testLinkFilenameDate = testCase "test to ensure the date can be acquired from the file name" $ do + -- Make a dummy copy of the source file. This test will be modifying + -- it, if successful. + let newOldPath = Util.resourcesPath "copy-of-foobar-2021-10-04-17-29-49-942.jpg" + copyFile (Util.resourcesPath "foobar-2021-10-04-17-29-49-942.jpg") newOldPath + let newLinkPathDate' = parentDir "2021/2021-10-04/20211004-172949.jpg" + + -- Run the program with known input data + (output, procH) <- Util.getBinaryOutput + [ "--parent-dir=" ++ parentDir, newOldPath ] + waitForProcess procH + + -- Check that the correct output path exists + existsNew <- fileExist newLinkPathDate' + assertBool "filename date: existance of new link" existsNew + + -- Check that old path still exists + existsOld <- fileExist newOldPath + assertBool "filename date: existance of old link" existsOld + + -- Remove files and dirs that were created + removeFile newOldPath + removeDirectoryRecursive parentDir + + -- WARNING We are NOT checking for the new EXIF tags in the files!! + + -- Test output to stdout + assertBool "filename date: correct output" + (output =~ newLinkPathDate' :: Bool) diff --git a/src/tests/Util.hs b/src/tests/Util.hs new file mode 100644 --- /dev/null +++ b/src/tests/Util.hs @@ -0,0 +1,39 @@ +module Util + ( resourcesPath + , getProcessOutput, getBinaryOutput + , assertFalse + ) + where + +import Data.List ( intercalate ) +import System.IO ( hGetContents ) +import System.Process ( ProcessHandle, runInteractiveCommand ) +import Test.Tasty.HUnit ( Assertion, assertBool ) + + +command :: String +command = "stack exec photoname" + + +resourcesPath :: FilePath +resourcesPath = "util/resources/test" + + +{- Quick and dirty function to run a process and grab its output. + This evil thing doesn't watch STDERR at all or otherwise do anything + even remotely safe. +-} +getProcessOutput :: String -> [String] -> IO (String, ProcessHandle) +getProcessOutput path' args = do + (_, outH, _, procH) <- runInteractiveCommand + $ path' ++ " -- " ++ (intercalate " " args) + output <- hGetContents outH + pure (output, procH) + + +getBinaryOutput :: [String] -> IO (String, ProcessHandle) +getBinaryOutput = getProcessOutput command + + +assertFalse :: String -> Bool -> Assertion +assertFalse l b = assertBool l $ not b diff --git a/src/tests/runtests.hs b/src/tests/runtests.hs new file mode 100644 --- /dev/null +++ b/src/tests/runtests.hs @@ -0,0 +1,14 @@ +module Main + where + +import Test.Tasty + +import qualified TestLink ( tests ) +import qualified Test.Photoname.Date ( tests ) + + +main :: IO () +main = defaultMain $ testGroup " tests" + [ Test.Photoname.Date.tests + , TestLink.tests + ] diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,10 @@ -resolver: lts-10.1 +resolver: nightly-2021-11-15 packages: - . -extra-deps: -- exif-3000.0.0 +extra-deps: [] + +flags: + hsexif: + iconv: false diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +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 diff --git a/testsuite/TestHelp.hs b/testsuite/TestHelp.hs deleted file mode 100644 --- a/testsuite/TestHelp.hs +++ /dev/null @@ -1,36 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -module TestHelp ( - testHelpAll -) - where - -import qualified Util -import Test.HUnit ( Test (..), assertEqual ) - - -testHelpAll :: Test -testHelpAll = TestList - [ TestLabel "testHelpSwitch" testHelpSwitch - , TestLabel "testHelpSwitchLong" testHelpSwitchLong - ] - -expectedFirstLine :: String -expectedFirstLine = "Usage: photoname [OPTIONS] FILES" - - -testHelpSwitch :: Test -testHelpSwitch = TestCase $ do - (allOutput, _) <- Util.getBinaryOutput ["-h"] - assertEqual "-h switch output" - expectedFirstLine - $ head $ lines allOutput - - -testHelpSwitchLong :: Test -testHelpSwitchLong = TestCase $ do - (allOutput, _) <- Util.getBinaryOutput ["--help"] - assertEqual "--help switch output" - expectedFirstLine - $ head $ lines allOutput diff --git a/testsuite/TestLink.hs b/testsuite/TestLink.hs deleted file mode 100644 --- a/testsuite/TestLink.hs +++ /dev/null @@ -1,247 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -module TestLink ( - testLinkAll -) - where - -import System.Directory ( copyFile, removeDirectoryRecursive ) -import System.FilePath.Posix ( (), (<.>) ) -import System.Posix.Files ( fileExist ) -import System.Process ( waitForProcess ) -import Test.HUnit ( Test (..), assertBool ) -import Text.Regex.Posix ( (=~) ) -import qualified Util - - -{- Test the normal behavior of hard-linking the original file to a new - path. --} - - -testLinkAll :: Test -testLinkAll = TestList - [ TestLabel "testLinkDate" testLinkDate - , TestLabel "testLinkSerial" testLinkSerial - , TestLabel "testMove" testMove - , TestLabel "testLinkNoAction" testLinkNoAction - , TestLabel "testLinkNoActionLong" testLinkNoActionLong - , TestLabel "testLinkQuiet" testLinkQuiet - , TestLabel "testLinkQuietLong" testLinkQuietLong - , TestLabel "testLinkSuffix" testLinkSuffix - , TestLabel "testNoExif" testNoExif - , TestLabel "testNoSerial" testNoSerial - , TestLabel "testDirForFile" testDirForFile - ] - - -topDir, oldPath, newLinkPathDate, newLinkPathSerial :: FilePath - -topDir = Util.resourcesPath "foo" -oldPath = Util.resourcesPath "img_1220.jpg" -newLinkPathDate = topDir "2003/2003-09-02/20030902-114303.jpg" -newLinkPathSerial = topDir "2003/2003-09-02/20030902_220.jpg" - - -testLinkDate :: Test -testLinkDate = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ topDir, oldPath ] - waitForProcess procH - - -- Check that the correct output path exists - existsNew <- fileExist newLinkPathDate - assertBool "make link: existance of new link" existsNew - - -- Check that old path still exists - existsOld <- fileExist oldPath - assertBool "make link: existance of old link" existsOld - - -- Remove files and dirs that were created - removeDirectoryRecursive topDir - - -- Test output to stdout - assertBool "make link: correct output" - (output =~ newLinkPathDate :: Bool) - - -testLinkSerial :: Test -testLinkSerial = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ topDir, "--old-style", oldPath ] - waitForProcess procH - - -- Check that the correct output path exists - existsNew <- fileExist newLinkPathSerial - assertBool "make link: existance of new link" existsNew - - -- Check that old path still exists - existsOld <- fileExist oldPath - assertBool "make link: existance of old link" existsOld - - -- Remove files and dirs that were created - removeDirectoryRecursive topDir - - -- Test output to stdout - assertBool "make link: correct output" - (output =~ newLinkPathSerial :: Bool) - - -testMove :: Test -testMove = TestCase $ do - let newNewLinkPath = topDir "2003/2003-09-02/20030902_321.jpg" - - -- Make a dummy copy of the source file. This test will be getting rid - -- of it, if successful. - let newOldPath = Util.resourcesPath "img_0321.jpg" - copyFile oldPath newOldPath - - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--move", "--parent-dir=" ++ topDir, "--old-style", newOldPath ] - waitForProcess procH - - -- Check that the correct output path exists - existsNew <- fileExist newNewLinkPath - assertBool "move file: existance of new link" existsNew - - -- Check that old path still exists - existsOld <- fileExist newOldPath - Util.assertFalse "move file: existance of old link" existsOld - - -- Remove files and dirs that were created - removeDirectoryRecursive topDir - - -- Test output to stdout - assertBool "move file: correct output" - (output =~ newNewLinkPath :: Bool) - - -testLinkNoAction :: Test -testLinkNoAction = testLinkNoAction' "no action" "-n" - - -testLinkNoActionLong :: Test -testLinkNoActionLong = testLinkNoAction' "no action long" "--no-action" - - -testLinkNoAction' :: String -> String -> Test -testLinkNoAction' label switch = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ switch, "--parent-dir=" ++ topDir, "--old-style", oldPath ] - waitForProcess procH - - -- Check that the correct output path exists - existsNew <- fileExist topDir - Util.assertFalse (label ++ ": existance of new link") existsNew - - -- Check that old path still exists - existsOld <- fileExist oldPath - assertBool (label ++ ": existance of old link") existsOld - - -- Test output to stdout - assertBool (label ++ ": correct output") - (output =~ newLinkPathSerial :: Bool) - - -testLinkQuiet :: Test -testLinkQuiet = testLinkQuiet' "make link quiet" "-q" - - -testLinkQuietLong :: Test -testLinkQuietLong = testLinkQuiet' "make link quiet long" "--quiet" - - --- Reusable test code for above short/long versions of the quiet switch -testLinkQuiet' :: String -> String -> Test -testLinkQuiet' label switch = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ switch, "--parent-dir=" ++ topDir, "--old-style", oldPath ] - waitForProcess procH - - -- Check that the correct output path exists - existsNew <- fileExist newLinkPathSerial - assertBool (label ++ ": existance of new link") existsNew - - -- Check that old path still exists - existsOld <- fileExist oldPath - assertBool (label ++ ": existance of old link") existsOld - - -- Remove files and dirs that were created - removeDirectoryRecursive topDir - - -- Test output to stdout - Util.assertFalse (label ++ ": no output") - (output =~ newLinkPathSerial :: Bool) - - -testLinkSuffix :: Test -testLinkSuffix = TestCase $ do - let suffix = "_dwm" - - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ topDir, "--suffix=" ++ suffix, oldPath ] - waitForProcess procH - - let newLinkPath = topDir - ("2003/2003-09-02/20030902-114303" ++ suffix) <.> "jpg" - - -- Check that the correct output path exists - existsNew <- fileExist newLinkPath - assertBool "make link: existance of new link" existsNew - - -- Check that old path still exists - existsOld <- fileExist oldPath - assertBool "make link: existance of old link" existsOld - - -- Remove files and dirs that were created - removeDirectoryRecursive topDir - - -- Test output to stdout - assertBool "make link: correct output" - (output =~ newLinkPath :: Bool) - - -testNoExif :: Test -testNoExif = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ topDir, Util.resourcesPath "noExif.jpg" ] - waitForProcess procH - - -- Test output to stdout - assertBool "no EXIF: correct output" - (output =~ "\\*\\* Processing testsuite/resources/noExif.jpg: Failed EXIF loading" :: Bool) - - -testNoSerial :: Test -testNoSerial = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ topDir - , "--old-style", Util.resourcesPath "noSerial.jpg" ] - waitForProcess procH - - -- Test output to stdout - assertBool "no serial in filename: correct output" - (output =~ "\\*\\* Processing testsuite/resources/noSerial.jpg: Can't determine serial" :: Bool) - - -testDirForFile :: Test -testDirForFile = TestCase $ do - -- Run the program with known input data - (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ topDir, Util.resourcesPath ] - waitForProcess procH - - -- Test output to stdout - assertBool "dir as file to change: correct output" - (output =~ "" :: Bool) diff --git a/testsuite/Util.hs b/testsuite/Util.hs deleted file mode 100644 --- a/testsuite/Util.hs +++ /dev/null @@ -1,42 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -module Util ( - resourcesPath, - getProcessOutput, getBinaryOutput, - assertFalse -) - where - -import Data.List ( intercalate ) -import System.IO ( hGetContents ) -import System.Process ( ProcessHandle, runInteractiveCommand ) -import Test.HUnit ( Assertion, assertBool ) - - -command :: String -command = "stack exec photoname" - - -resourcesPath :: FilePath -resourcesPath = "testsuite/resources" - - -{- Quick and dirty function to run a process and grab its output. - This evil thing doesn't watch STDERR at all or otherwise do anything - even remotely safe. --} -getProcessOutput :: FilePath -> [String] -> IO (String, ProcessHandle) -getProcessOutput path' args = do - (_, outH, _, procH) <- runInteractiveCommand - $ path' ++ " -- " ++ (intercalate " " args) - output <- hGetContents outH - return (output, procH) - - -getBinaryOutput :: [String] -> IO (String, ProcessHandle) -getBinaryOutput = getProcessOutput command - - -assertFalse :: String -> Bool -> Assertion -assertFalse l b = assertBool l $ not b diff --git a/testsuite/resources/img_1220.jpg b/testsuite/resources/img_1220.jpg deleted file mode 100644 Binary files a/testsuite/resources/img_1220.jpg and /dev/null differ diff --git a/testsuite/resources/noExif.jpg b/testsuite/resources/noExif.jpg deleted file mode 100644 --- a/testsuite/resources/noExif.jpg +++ /dev/null @@ -1,1 +0,0 @@ -This is not an image file at all! diff --git a/testsuite/resources/noSerial.jpg b/testsuite/resources/noSerial.jpg deleted file mode 100644 Binary files a/testsuite/resources/noSerial.jpg and /dev/null differ diff --git a/testsuite/runtests.hs b/testsuite/runtests.hs deleted file mode 100644 --- a/testsuite/runtests.hs +++ /dev/null @@ -1,32 +0,0 @@ --- License: BSD3 (see LICENSE) --- Author: Dino Morelli - -module Main - where - -import System.Exit -import Test.HUnit ( Counts (..), Test (..), runTestTT ) -import TestHelp -import TestLink - - -main :: IO () -main = do - counts <- runTestTT tests - exit $ testsPassed counts - - -exit :: Bool -> IO () -exit True = exitWith ExitSuccess -exit False = exitWith $ ExitFailure 1 - - -testsPassed :: Counts -> Bool -testsPassed (Counts _ _ e f) = (e == 0) && (f == 0) - - -tests :: Test -tests = TestList - [ TestLabel "testHelpAll" testHelpAll - , TestLabel "testLinkAll" testLinkAll - ] diff --git a/util/install.hs b/util/install.hs deleted file mode 100644 --- a/util/install.hs +++ /dev/null @@ -1,295 +0,0 @@ -#! /usr/bin/env stack -{- stack runghc -} - -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.Exception -import Control.Monad -import Data.List -import Distribution.Package -import Distribution.PackageDescription hiding ( error, options ) -import Distribution.PackageDescription.Parse -import Distribution.Verbosity -import Distribution.Version -import System.Console.GetOpt -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process -import Text.Printf -import Text.Read - - -defaultOptions :: Options -defaultOptions = Options - { optClean = False - , optDelete = False - , optHelp = False - , optPrefix = "/opt" - , optRsrcCpVerbose = True - , optInstType = FHS - , optVersion = True - } - -data InstallType = Bundle | FHS - - -main :: IO () -main = do - -- Parse args - (opts, _) <- parseOpts =<< getArgs - - -- User asked for help - when (optHelp opts) $ putStrLn usageText >> exitSuccess - - -- Locate cabal file - cabalFiles <- (filter $ isSuffixOf ".cabal") <$> getDirectoryContents "." - - when (null cabalFiles) $ do - die "Can't continue because no cabal files were found in ." - - -- Parse the cabal file and extract things we need from it - -- then pass a pile of what we know to a function to create the - -- installation dirs - dirs <- constructDirs opts . package . packageDescription - <$> readGenericPackageDescription normal (head cabalFiles) - - - -- Perform the installation - - -- Remove existing install directory - appDirExists <- doesDirectoryExist $ appDir dirs - when (optDelete opts && appDirExists) $ do - putStrLn $ "Removing existing directory " ++ (appDir dirs) - removeDirectoryRecursive $ appDir dirs - - -- Clean before building - when (optClean opts) $ system "stack clean" >> return () - - -- Copy the binaries - installExitCode <- system $ "stack install --local-bin-path=" ++ (binDir dirs) - unless (ok installExitCode) $ die "Can't continue because stack install failed" - - -- Copy the license - putStrLn "\nCopying LICENSE" - createDirectoryIfMissing True $ docDir dirs - copyFile "LICENSE" (docDir dirs "LICENSE") - - -- Copy the resources - let rsrcDirSrc = "." "resources" - rsrcsExist <- doesDirectoryExist rsrcDirSrc - when rsrcsExist $ do - putStrLn $ "\nCopying resources" - copyTree (optRsrcCpVerbose opts) rsrcDirSrc (rsrcDir dirs) - return () - - exitSuccess - - -data Dirs = Dirs - { appDir :: FilePath - , binDir :: FilePath - , docDir :: FilePath - , rsrcDir :: FilePath - } - - -constructDirs :: Options -> PackageId -> Dirs -constructDirs opts pkgId = - Dirs appDir binDir' (appDir "doc") (appDir "resources") - - where - project = unPackageName . pkgName $ pkgId - version = showVersion . pkgVersion $ pkgId - versionPart = if optVersion opts then "-" ++ version else "" - appDir = case (optInstType opts) of - Bundle -> optPrefix opts (project ++ versionPart) - FHS -> optPrefix opts "share" (project ++ versionPart) - binDir' = case (optInstType opts) of - Bundle -> appDir "bin" - FHS -> optPrefix opts "bin" - - -{- Turn an exit code (say, from system) into a Bool --} -ok :: ExitCode -> Bool -ok ExitSuccess = True -ok _ = False - - -{- - Argument parsing code --} - -data Options = Options - { optClean :: Bool - , optDelete :: Bool - , optHelp :: Bool - , optPrefix :: FilePath - , optRsrcCpVerbose :: Bool - , optInstType :: InstallType - , optVersion :: Bool - } - - -instance Read InstallType where - readsPrec _ "bundle" = [(Bundle, "")] - readsPrec _ "fhs" = [(FHS, "")] - readsPrec _ _ = [] - -instance Show InstallType where - show Bundle = "bundle" - show FHS = "fhs" - - -readInstallType :: String -> InstallType -readInstallType s = - case (readEither s) of - Left _ -> error $ printf "Can't continue because %s is not a valid install type\n\n%s" s usageText - Right t -> t - - -options :: [OptDescr (Options -> Options)] -options = - [ Option ['c'] ["clean"] - (NoArg (\opts -> opts { optClean = True } )) - ("Do 'stack clean' first." ++ (defaultText . optClean $ defaultOptions)) - , Option ['C'] ["no-clean"] - (NoArg (\opts -> opts { optClean = False } )) - ("Do not 'stack clean' first." - ++ (defaultText . not . optClean $ defaultOptions)) - , Option ['d'] ["delete"] - (NoArg (\opts -> opts { optDelete = True } )) - ("Delete the app directory before copying files." - ++ (defaultText . optDelete $ defaultOptions)) - , Option ['D'] ["no-delete"] - (NoArg (\opts -> opts { optDelete = False } )) - ("Do not delete the app directory before copying files." - ++ (defaultText . not . optDelete $ defaultOptions)) - , Option ['h'] ["help"] - (NoArg (\opts -> opts { optHelp = True } )) - "This help information." - , Option ['p'] ["prefix"] - (ReqArg (\s opts -> opts { optPrefix = s } ) "PREFIX" ) - (printf "Install prefix directory. Defaults to %s so what you'll end up with is %s/PROJECT-VERSION" - (optPrefix defaultOptions) (optPrefix defaultOptions)) - , Option ['r'] ["resource-copy-verbose"] - (NoArg (\opts -> opts { optRsrcCpVerbose = True } )) - ("Be chatty when copying the resources directory." - ++ (defaultText . optRsrcCpVerbose $ defaultOptions)) - , Option ['R'] ["no-resource-copy-verbose"] - (NoArg (\opts -> opts { optRsrcCpVerbose = False } )) - ("Don't be chatty when copying the resources directory. Useful when there are a LOT of resources." - ++ (defaultText . not . optRsrcCpVerbose $ defaultOptions)) - , Option ['t'] ["type"] - (ReqArg (\s opts -> opts { optInstType = readInstallType s } ) "INST_TYPE" ) - (printf "Installation type, see INSTALLATION TYPE below for details. Default: %s" - (show . optInstType $ defaultOptions)) - , Option ['v'] ["version"] - (NoArg (\opts -> opts { optVersion = True } )) - (printf "Include version in installation path, meaning: %s/PROJECT-VERSION %s" - (optPrefix defaultOptions) (defaultText . optVersion $ defaultOptions)) - , Option ['V'] ["no-version"] - (NoArg (\opts -> opts { optVersion = False } )) - (printf "Do not include version in installation path, meaning: %s/PROJECT %s" - (optPrefix defaultOptions) (defaultText . not . optVersion $ defaultOptions)) - ] - - -defaultText :: Bool -> String -defaultText True = " Default" -defaultText False = "" - - -parseOpts :: [String] -> IO (Options, [String]) -parseOpts args = - case getOpt Permute options args of - (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) - (_,_,errs) -> ioError $ userError (concat errs ++ usageText) - - -usageText :: String -usageText = (usageInfo header options) ++ "\n" ++ footer - where - header = init $ unlines - [ "Usage: install.hs [OPTIONS]" - , "" - , "options:" - ] - footer = init $ unlines - [ "INSTALLATION TYPE" - , "" - , "This is the topology used when copying files, one of: bundle, fhs" - , "" - , "bundle is sort-of a self-contained structure like this:" - , "" - , " $PREFIX/" - , " $PROJECT-$VERSION/ <-- this is the \"app directory\"" - , " bin/..." - , " doc/LICENSE" - , " resources/..." - , "" - , "fhs is the more traditional UNIX structure like this:" - , "" - , " $PREFIX/" - , " bin/..." - , " share/" - , " $PROJECT-$VERSION/ <-- this is the \"app directory\"" - , " doc/LICENSE" - , " resources/..." - , "" - , "Be aware that when the --delete switch is used along with fhs type, the binaries WILL NOT be deleted, only the \"app directory\"." - , "" - , "COMPILING" - , "" - , "install.hs was intentionally left as a script, but if you would prefer to compile it, do this:" - , "" - , " $ stack ghc -- -o util/install util/install.hs" - , "" - , "" - , "This script is part of the hsinstall package by Dino Morelli " - ] - - -{- - Recursive file copying code - - It was desireable to have a standalone recursive file copy in - this script for maximum cross-platform compatibility and to - avoid Haskell library dependencies. - - Many thanks to [abuzittin gillifirca](https://codereview.stackexchange.com/users/20251/abuzittin-gillifirca) for the StackOverflow post [Copying files in Haskell](https://codereview.stackexchange.com/questions/68908/copying-files-in-haskell) where the following code was lifted. --} - -copyTree :: Bool -> FilePath -> FilePath -> IO () -copyTree chatty s t = do - createDirectoryIfMissing True t - subItems <- getSubitems s - mapM_ (copyItem chatty s t) subItems - - -getSubitems :: FilePath -> IO [(Bool, FilePath)] -getSubitems path = getSubitems' "" - where - getChildren path = (\\ [".", ".."]) <$> getDirectoryContents path - - getSubitems' relPath = do - let absPath = path relPath - isDir <- doesDirectoryExist absPath - children <- if isDir then getChildren absPath else return [] - let relChildren = [relPath p | p <- children] - ((isDir, relPath) :) . concat <$> mapM getSubitems' relChildren - - -copyItem :: Bool -> FilePath -> FilePath -> (Bool, FilePath) -> IO () -copyItem chatty baseSourcePath baseTargetPath (isDir, relativePath) = do - let sourcePath = baseSourcePath relativePath - let targetPath = baseTargetPath relativePath - - when chatty $ - putStrLn $ "Copying " ++ sourcePath ++ " to " ++ targetPath - - if isDir - then createDirectoryIfMissing False targetPath - else copyFile sourcePath targetPath diff --git a/util/resources/test.conf b/util/resources/test.conf deleted file mode 100644 --- a/util/resources/test.conf +++ /dev/null @@ -1,4 +0,0 @@ -move -old-style -parent-dir=~/mypics -suffix=_dwm diff --git a/util/resources/test/dateTime.jpg b/util/resources/test/dateTime.jpg new file mode 100644 Binary files /dev/null and b/util/resources/test/dateTime.jpg differ diff --git a/util/resources/test/dateTimeDigitized.jpg b/util/resources/test/dateTimeDigitized.jpg new file mode 100644 Binary files /dev/null and b/util/resources/test/dateTimeDigitized.jpg differ diff --git a/util/resources/test/dateTimeOriginal.jpg b/util/resources/test/dateTimeOriginal.jpg new file mode 100644 Binary files /dev/null and b/util/resources/test/dateTimeOriginal.jpg differ diff --git a/util/resources/test/foobar-2021-10-04-17-29-49-942.jpg b/util/resources/test/foobar-2021-10-04-17-29-49-942.jpg new file mode 100644 Binary files /dev/null and b/util/resources/test/foobar-2021-10-04-17-29-49-942.jpg differ diff --git a/util/resources/test/noDate.jpg b/util/resources/test/noDate.jpg new file mode 100644 Binary files /dev/null and b/util/resources/test/noDate.jpg differ diff --git a/util/resources/test/noExif.jpg b/util/resources/test/noExif.jpg new file mode 100644 Binary files /dev/null and b/util/resources/test/noExif.jpg differ diff --git a/util/resources/test/notAnImage.txt b/util/resources/test/notAnImage.txt new file mode 100644 --- /dev/null +++ b/util/resources/test/notAnImage.txt @@ -0,0 +1,1 @@ +This is not an image file at all! diff --git a/util/resources/test/test.conf b/util/resources/test/test.conf new file mode 100644 --- /dev/null +++ b/util/resources/test/test.conf @@ -0,0 +1,3 @@ +move +parent-dir=~/mypics +suffix=_dwm