packages feed

photoname 5.0 → 5.1

raw patch · 19 files changed

+575/−498 lines, 19 files

Files

README.md view
@@ -26,9 +26,8 @@ And once you have it, building the usual way:      $ stack build+    $ stack test --ta all     $ stack run-    $ stack test-    $ stack clean  If you're just looking, [browse the source](https://github.com/dino-/photoname)
changelog.md view
@@ -1,3 +1,11 @@+5.1 (2022-01-11)++  * Added new number-of-links filtering feature+  * End-to-end tests are now optional+  * Fixed some spelling and wording issues+  * Applied hlint suggestions++ 5.0 (2020-11-26)    * Updated Stackage resolver
package.yaml view
@@ -1,5 +1,5 @@ name: photoname-version: '5.0'+version: '5.1' license: ISC copyright: 2007-2021 Dino Morelli author: Dino Morelli
photoname.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           photoname-version:        5.0+version:        5.1 synopsis:       Rename photo image files based on EXIF shoot date description:    Command-line utility for renaming/moving photo image files based on EXIF tags. category:       Application, Console@@ -50,6 +50,7 @@       Photoname.Date       Photoname.Exif       Photoname.Exiv2+      Photoname.Links       Photoname.Log   other-modules:       Paths_photoname@@ -96,9 +97,9 @@   type: exitcode-stdio-1.0   main-is: runtests.hs   other-modules:-      Test.Photoname.Date-      TestLink-      Util+      Photoname.Test.EndToEnd.Link+      Photoname.Test.EndToEnd.Util+      Photoname.Test.Unit.Date       Paths_photoname   hs-source-dirs:       src/tests
src/app/Photoname/Opts.hs view
@@ -21,6 +21,7 @@   ( Artist (..)   , ConfigPath (..)   , CopySwitch (..)+  , Links (Exactly, NoLimit)   , MoveSwitch (..)   , NoActionSwitch (..)   , NoDirsSwitch (..)@@ -60,6 +61,13 @@         <> help "No subdirectory hierarchy. Just do DIR/NEWFILE"         )       )+  <*> option (Exactly <$> auto)+        (  long "links"+        <> short 'l'+        <> metavar "NUM"+        <> help "Reject files unless they have this many hard links. See LINKS. Default: accept all files"+        <> value NoLimit+        )   <*> ( MoveSwitch <$> switch         (  long "move"         <> help "Move the files, don't just hard-link to the new locations. In other words, remove the source path."@@ -104,7 +112,7 @@         <> showDefault         <> value (Verbose INFO)         )-  <*> ( some $ strArgument+  <*> some ( strArgument         $ metavar "FILES..."       ) @@ -117,7 +125,7 @@    confExists <- doesFileExist path     if confExists-      then (map ("--" ++) . lines) <$> readFile path+      then map ("--" ++) . lines <$> readFile path       else do         hPutStrLn stderr $ "Config file " <> path <> " does not exist!"         exitFailure@@ -140,7 +148,7 @@   case optConfig cliOpts of     Just configPath -> do       confArgs <- loadConfig configPath-      parseOpts' $ confArgs <> (optPaths cliOpts)+      parseOpts' $ confArgs <> optPaths cliOpts     Nothing -> pure cliOpts  @@ -201,6 +209,10 @@ 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=''++LINKS++A common use of photoname is to process a directory of images, leaving you with 2 hard links to the original files. If at a later time you want to process any new images in the same directory, they could be identified by their different number of links. The -l|--links switch can perform this filtering in lieu of using another tool like `find`.  PREFIX
src/app/photoname.hs view
@@ -1,14 +1,18 @@ import Control.Monad ( filterM, forM_, when ) import Control.Newtype.Generics ( op )-import System.Posix ( getFileStatus, isRegularFile )+import Data.Functor ( (<&>) )+import System.Posix ( FileStatus, getFileStatus, isRegularFile ) import Text.Printf ( printf ) -import Photoname.Common ( CopySwitch (..), MoveSwitch (..),-  NoActionSwitch (..), Options (..), Ph, SrcPath (..), runRename )+import Photoname.Common+  ( CopySwitch (..), Links, MoveSwitch (..), NoActionSwitch (..)+  , Options (..), Ph, SrcPath (..), runRename+  ) import Photoname.CopyLink ( createNewLink ) import Photoname.Date ( PhDate, parseExifDate, parseFilenameDate ) import Photoname.Exif ( getExifDate ) import Photoname.Exiv2 ( setArtist, setExifDate )+import Photoname.Links ( describeHardLinkPolicy, linksTest ) import Photoname.Log ( errorM, initLogging, infoM, lname ) import Photoname.Opts ( parseOpts ) @@ -30,6 +34,17 @@   setArtist destPath  +-- Get rid of anything not a regular file or with a number of links that+-- doesn't match our links amount which is either passed in by the user with+-- the -l|--links switch or any number of links is fine.+filterWantedFiles :: Links -> [FilePath] -> IO [SrcPath]+filterWantedFiles links inputFiles = map SrcPath <$> filterM (\p ->+    getFileStatus p <&> testFile) inputFiles+  where+    testFile :: FileStatus -> Bool+    testFile fileStatus = isRegularFile fileStatus && linksTest links fileStatus++ -- Figure out and execute what the user wants based on the supplied args. main :: IO () main = do@@ -37,10 +52,6 @@     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."@@ -51,10 +62,17 @@    when (op MoveSwitch . optMove $ opts) $       infoM lname "Removing original links after new links are in place." +   describeHardLinkPolicy $ optLinks opts++   actualPaths <- filterWantedFiles (optLinks opts) (optPaths opts)+    -- 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+      either+        {- HLINT ignore "Avoid lambda" -}+        -- Because the compiler can't figure out printf is expecting an argument at compile time+        (\em -> errorM lname $ printf "** Processing %s: %s\n" (op SrcPath srcPath) em)+        pure result     -- Perhaps we should get an ExitCode back from all this above?
src/lib/Photoname/Common.hs view
@@ -5,6 +5,7 @@   , ConfigPath (..)   , CopySwitch (..)   , DestPath (..)+  , Links(..)   , MoveSwitch (..)   , NoActionSwitch (..)   , NoDirsSwitch (..)@@ -32,6 +33,7 @@ import Control.Newtype.Generics import GHC.Generics import System.Log.Logger ( Priority (..) )+import System.Posix ( CNlink )   data Verbosity@@ -67,6 +69,8 @@  instance Newtype NoDirsSwitch +data Links = Exactly CNlink | NoLimit+ newtype MoveSwitch = MoveSwitch Bool   deriving Generic @@ -97,6 +101,7 @@   , optConfig     :: Maybe ConfigPath   , optCopy       :: CopySwitch   , optNoDirs     :: NoDirsSwitch+  , optLinks      :: Links   , optMove       :: MoveSwitch   , optNoAction   :: NoActionSwitch   , optParentDir  :: ParentDir
src/lib/Photoname/CopyLink.hs view
@@ -34,7 +34,7 @@     FilenameDate lt -> buildDatePath lt     NoDateFound -> throwError "Could not extract any date information" -  -- Check for existance of the target file+  -- Check for existence of the target file   exists <- liftIO $ fileExist destFp   when exists $ throwError $ "Destination " ++ destFp ++ " exists!" @@ -46,7 +46,7 @@     liftIO $ createDirectoryIfMissing True $ takeDirectory destFp      -- Make the new file-    if (op CopySwitch . optCopy $ opts)+    if op CopySwitch . optCopy $ opts       then liftIO $ copyFile srcFp destFp       else tryHardLink srcPath destPath @@ -80,7 +80,7 @@     parentFp <- asks (op ParentDir . optParentDir)    noDirs <- asks (op NoDirsSwitch . optNoDirs)-   pure . DestPath $ if (noDirs)+   pure . DestPath $ if noDirs       then parentFp </> fileName-      else parentFp </> (formatYear date) </>-         (formatDateHyphens date) </> fileName+      else parentFp </> formatYear date </>+         formatDateHyphens date </> fileName
src/lib/Photoname/Date.hs view
@@ -56,7 +56,7 @@ parseExifDate :: Maybe String -> PhDate parseExifDate Nothing = NoDateFound parseExifDate (Just s) =-   case (parse dateParser "" s) of+   case parse dateParser "" s of       Left _  -> NoDateFound       Right x -> ExifDate x    where@@ -69,7 +69,7 @@             LocalTime                (fromGregorian (read year) (read month) (read day))                (TimeOfDay (read hour) (read minute)-                  (fromIntegral ((read second) :: Integer)))+                  (fromIntegral (read second :: Integer)))   {- Parse a string in one of the the forms below into a CalendarTime datatype.@@ -85,7 +85,7 @@ -} parseFilenameDate :: SrcPath -> PhDate parseFilenameDate srcPath =-  case (parse dateParser "" (takeFileName . op SrcPath $ srcPath)) of+  case parse dateParser "" (takeFileName . op SrcPath $ srcPath) of     Left _  -> NoDateFound     Right x -> FilenameDate x   where@@ -106,7 +106,7 @@          LocalTime             (fromGregorian (read year) (read month) (read day))             (TimeOfDay (read hour) (read minute)-               (fromIntegral ((read second) :: Integer)))+               (fromIntegral (read second :: Integer)))   {- Format a Maybe CalendarTime into a "yyyy" string
src/lib/Photoname/Exif.hs view
@@ -32,5 +32,5 @@ extractDate (Left _) = Nothing extractDate (Right exifMap) =   -- Find the first date available in the Map-  show <$> ( ala First foldMap $ map (flip M.lookup exifMap)-    [dateTimeOriginal, dateTimeDigitized, dateTime] )+  show <$> ala First foldMap (map (flip M.lookup exifMap)+    [dateTimeOriginal, dateTimeDigitized, dateTime])
src/lib/Photoname/Exiv2.hs view
@@ -29,8 +29,6 @@   unless (op NoActionSwitch . optNoAction $ opts) $     liftIO $ mapM_ (callCommand . unCommand) commands -  pure ()-  setArtist :: DestPath -> Ph () setArtist (DestPath destFp) = do
+ src/lib/Photoname/Links.hs view
@@ -0,0 +1,24 @@+module Photoname.Links+  ( describeHardLinkPolicy+  , linksTest+  )+  where++import System.Posix ( FileStatus, linkCount )+import Text.Printf ( printf )++import Photoname.Common ( Links (Exactly, NoLimit) )+import Photoname.Log ( infoM, lname )+++linksTest :: Links -> FileStatus -> Bool+linksTest (Exactly linkCountWanted) fileStatus = linkCountWanted == linkCount fileStatus+linksTest NoLimit                   _          = True+++describeHardLinkPolicy :: Links -> IO ()+describeHardLinkPolicy l = case l of+  Exactly 1 -> infoM lname          "Only processing files with 1 hard link"+  Exactly n -> infoM lname $ printf "Only processing files with %d hard links" (toInteger n)+  NoLimit   -> pure ()+
+ src/tests/Photoname/Test/EndToEnd/Link.hs view
@@ -0,0 +1,340 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Photoname.Test.EndToEnd.Link+  ( 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 Photoname.Test.EndToEnd.Util as 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: existence of new link" existsNew++   -- Check that old path still exists+   existsOld <- fileExist oldPath+   assertBool "make link, date digitized: existence 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: existence of new link" existsNew++   -- Check that old path still exists+   existsOld <- fileExist digitizedOldPath+   assertBool "make link, date original: existence 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: existence of new link" existsNew++   -- Check that old path still exists+   existsOld <- fileExist dateOldPath+   assertBool "make link, date: existence 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: existence of new link" existsNew++   -- Check that old path still exists+   existsOld <- fileExist newOldPath+   Util.assertFalse "move file: existence 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 ++ ": existence of new link") existsNew++   -- Check that old path still exists+   existsOld <- fileExist oldPath+   assertBool (label ++ ": existence 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 ++ ": existence of new link") existsNew++   -- Check that old path still exists+   existsOld <- fileExist oldPath+   assertBool (label ++ ": existence 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: existence of new link" existsNew++   -- Check that old path still exists+   existsOld <- fileExist oldPath+   assertBool "make link: existence 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: existence of new link" existsNew++  -- Check that old path still exists+  existsOld <- fileExist oldPath+  assertBool "make link: existence 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: existence of new link" existsNew++   -- Check that old path still exists+   existsOld <- fileExist newOldPath+   assertBool "filename date: existence 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)
+ src/tests/Photoname/Test/EndToEnd/Util.hs view
@@ -0,0 +1,38 @@+module Photoname.Test.EndToEnd.Util+  ( resourcesPath+  , getProcessOutput, getBinaryOutput+  , assertFalse+  )+  where++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' <> " -- " <> unwords 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
+ src/tests/Photoname/Test/Unit/Date.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Photoname.Test.Unit.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+      ]++{- HLINT ignore "Monoid law, right identity" -}+{- HLINT ignore "Monoid law, left identity" -}+{- HLINT ignore "Use mconcat" -}+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+  ]
− src/tests/Test/Photoname/Date.hs 
@@ -1,81 +0,0 @@-{-# 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-  ]
− src/tests/TestLink.hs 
@@ -1,340 +0,0 @@-{-# 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)
− src/tests/Util.hs 
@@ -1,39 +0,0 @@-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
src/tests/runtests.hs view
@@ -1,14 +1,24 @@ module Main    where +import System.Environment ( getArgs, withArgs ) import Test.Tasty -import qualified TestLink ( tests )-import qualified Test.Photoname.Date ( tests )+import qualified Photoname.Test.EndToEnd.Link as Link+import qualified Photoname.Test.Unit.Date as Date  +{- Defaults to only running the unit tests. To run everything:++    $ stack test --ta all+    $ stack test --test-arguments all+-}+ main :: IO ()-main = defaultMain $ testGroup " tests"-  [ Test.Photoname.Date.tests-  , TestLink.tests-  ]+main = do+  args <- getArgs+  let baseTests = [ Date.tests ]+  let tests = if "all" `elem` args+        then Link.tests : baseTests+        else baseTests+  withArgs [] $ defaultMain $ testGroup " tests" tests