diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,12 +15,12 @@ ## Getting binaries -photoname is available for Linux in AppImage form [from github](https://github.com/dino-/photoname/releases) +photoname is available for Linux in AppImage form [from codeberg](https://codeberg.org/dinofp/photoname/releases) ## Getting source -- Get the source with git: `$ git clone https://github.com/dino-/photoname.git` +- Get the source with git: `$ git clone https://codeberg.org/dinofp/photoname.git` - Download the cabalized source package [from Hackage](http://hackage.haskell.org/package/photoname) And once you have it, building the usual way: @@ -29,13 +29,13 @@ $ stack test --ta all $ stack run -If you're just looking, [browse the source](https://github.com/dino-/photoname) +If you're just looking, [browse the source](https://codeberg.org/dinofp/photoname) ## Building for release For Linux builds, I recommend using the excellent -[hsinstall](https://github.com/dino-/hsinstall) utility which will simplify +[hsinstall](https://codeberg.org/dinofp/hsinstall) utility which will simplify creation of an [AppImage](https://appimage.org/) executable. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,19 @@ +5.5 (2025-08-11) + + * Changed logging from hslogger to co-log-simple + * Extensive redesign work because of the logging changes + * Removed unused and duplicate LANGUAGE directives + * Replaced remaining ++ with <> + * Implemented hlint suggestions + * Fixed formatting issues in the cabal file + * Moved Stackage snapshot up to lts-22.6 + + +5.4 (2024-11-21) + + * Reverted lookup order of EXIF date tags + + 5.3 (2024-11-18) * Now looking for the 3 EXIF tags when using exiv2 diff --git a/photoname.cabal b/photoname.cabal --- a/photoname.cabal +++ b/photoname.cabal @@ -1,17 +1,16 @@ cabal-version: 2.2 name: photoname -version: 5.4 +version: 5.5 synopsis: Rename photo image files based on EXIF shoot date description: Command-line utility for renaming/moving photo image files based on EXIF tags. -category: Application, Console -stability: stable -homepage: https://github.com/dino-/photoname -bug-reports: https://github.com/dino-/photoname/issues author: Dino Morelli maintainer: Dino Morelli copyright: 2007 Dino Morelli +category: Application, Console +homepage: https://codeberg.org/dinofp/photoname +bug-reports: https://codeberg.org/dinofp/photoname/issues license: ISC license-file: LICENSE build-type: Simple @@ -37,7 +36,7 @@ source-repository head type: git - location: https://github.com/dino-/photoname + location: https://codeberg.org/dinofp/photoname.git common lang default-language: Haskell2010 @@ -49,6 +48,8 @@ DeriveLift DeriveTraversable EmptyCase + FlexibleContexts + FlexibleInstances GeneralizedNewtypeDeriving ImportQualifiedPost InstanceSigs @@ -58,6 +59,7 @@ MultiWayIf NamedFieldPuns NumericUnderscores + OverloadedStrings ScopedTypeVariables StandaloneDeriving TupleSections @@ -71,9 +73,10 @@ -Wredundant-constraints build-depends: base >=4.5 && <5.0 - , directory >= 1.3.6 && < 1.4 - , filepath >= 1.4.2 && < 1.5 - , unix >= 2.7.2 && < 2.8 + , co-log-simple >=1.1.0 && <2 + , directory >=1.3.6 && <1.4 + , filepath >=1.4.2 && <1.5 + , unix >=2.7.2 && <3 library import: lang @@ -85,6 +88,7 @@ Photoname.Exiv2 Photoname.Links Photoname.Log + Photoname.Monad other-modules: Paths_photoname autogen-modules: @@ -92,14 +96,15 @@ hs-source-dirs: src/lib build-depends: - containers >= 0.6.5 && < 0.7 - , formatting >= 7.2.0 && < 7.3 - , hsexif >= 0.6.1 && < 0.7 - , hslogger >= 1.3.1 && < 1.4 - , mtl >= 2.2.2 && < 2.3 - , parsec >= 3.1.15 && < 3.2 - , process >= 1.6.16 && < 1.7 - , time >= 1.11.1 && < 1.13 + ansi-terminal >=1.0.2 && <2 + , containers >=0.6.5 && <0.7 + , formatting >=7.2.0 && <7.3 + , hsexif >=0.6.1 && <0.7 + , mtl >=2.3.1 && <2.4 + , parsec >=3.1.15 && <3.2 + , process >=1.6.16 && <1.7 + , text >=2.0.2 && <2.2 + , time >=1.11.1 && <1.13 executable photoname import: lang @@ -112,12 +117,11 @@ hs-source-dirs: src/app build-depends: - ansi-wl-pprint >= 0.6.9 && < 0.7 - , formatting >= 7.2.0 && < 7.3 - , heredoc >= 0.2.0 && < 0.3 - , hslogger >= 1.3.1 && < 1.4 - , optparse-applicative >= 0.17.1 && < 0.18 + formatting >=7.2.0 && <7.3 + , heredoc >=0.2.0 && <0.3 + , optparse-applicative >=0.17.1 && <0.19 , photoname + , prettyprinter >=1.7.1 && <2 test-suite photoname-tests import: lang @@ -131,9 +135,9 @@ src/tests build-depends: photoname - , process >= 1.6.16 && < 1.7 - , regex-posix - , tasty - , tasty-hunit - , tasty-quickcheck - , time >= 1.11.1 && < 1.13 + , process >=1.6.16 && <1.7 + , regex-posix >=0.96.0.1 && <1 + , tasty >=1.4.3 && <1.6 + , tasty-hunit >=0.10.1 && <0.11 + , tasty-quickcheck >=0.10.2 && <0.12 + , time >=1.11.1 && <1.13 diff --git a/src/app/Photoname/Opts.hs b/src/app/Photoname/Opts.hs --- a/src/app/Photoname/Opts.hs +++ b/src/app/Photoname/Opts.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} module Photoname.Opts ( parseOpts @@ -6,16 +6,15 @@ where import Data.Version (showVersion) -import Formatting ((%), (%+), formatToString, string) +import Formatting ((%), (%+), format, formatToString, string) import Options.Applicative import Paths_photoname (version) +import Prettyprinter (pretty) import System.Directory (doesFileExist) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) -import System.Log (Priority (NOTICE)) import Text.Heredoc (here) -import Text.PrettyPrint.ANSI.Leijen qualified as Leijen import Photoname.Common ( Artist (..) @@ -29,6 +28,7 @@ , Options (..) , ParentDir (..) , Prefix (..) + , Severity (..) , Suffix (..) , Verbosity (Verbose) , defaultDateTimeFormat @@ -129,7 +129,7 @@ <> metavar "NUM" <> help "Verbosity level. 0=quiet, 1=normal messages, 2=more info, 3=debug" <> showDefault - <> value (Verbose NOTICE) + <> value (Verbose Notice) ) <*> some ( strArgument $ metavar "FILES..." @@ -144,7 +144,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 @@ -185,8 +185,8 @@ footer' :: InfoMod a -footer' = footerDoc . Just . Leijen.string - $ formatToString content defaultDateTimeFormat (showVersion version) +footer' = footerDoc . Just . pretty + $ format content defaultDateTimeFormat (showVersion version) where content = [here|OVERVIEW This software is for renaming and storing your digital photos. It will attempt to construct a meaningful filename based on the EXIF shoot date in the file or possibly date/time info in the old filename, and optionally some other information. diff --git a/src/app/photoname.hs b/src/app/photoname.hs --- a/src/app/photoname.hs +++ b/src/app/photoname.hs @@ -1,20 +1,28 @@ -{-# LANGUAGE OverloadedRecordDot, OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} -import Control.Monad (filterM, forM_, when) -import Formatting ((%), (%+), formatToString, string) +import Colog.Simple (logNotice) +-- import Colog.Simple (logTest) +import Control.Monad (filterM, when) +import Formatting ((%), sformat, string) import Data.Functor ((<&>)) +import System.IO + ( BufferMode (NoBuffering) + , hSetBuffering + , stderr, stdout + ) import System.Posix (FileStatus, getFileStatus, isRegularFile) import Photoname.Common (CopySwitch (v), Extension (Extension, UseExistingExtension), Links, MoveSwitch (v), NoActionSwitch (v), Options (copy, extension, links, move, noAction, paths, - verbosity), Ph, SrcPath (SrcPath, v), liftIO, runRename) + verbosity), SrcPath (SrcPath)) import Photoname.CopyLink (createNewLink) import Photoname.Date (PhDate, parseExifDate, parseFilenameDate) import Photoname.Exif (getExifDate) import Photoname.Exiv2 (getExifDateWithExiv2, setArtist, setExifDate) import Photoname.Links (describeHardLinkPolicy, linksTest) -import Photoname.Log (errorM, initLogging, lname, noticeM) +import Photoname.Log (logger) +import Photoname.Monad (Env (..), Ph, liftIO, runRename) import Photoname.Opts (parseOpts) @@ -29,11 +37,14 @@ processFile :: SrcPath -> Ph () processFile srcPath = do - liftIO . noticeM lname $ "----------" + logNotice "------------------------------------------------------------" imageDate <- acquireDate srcPath - destPath <- createNewLink imageDate srcPath - setExifDate imageDate destPath - setArtist destPath + mbDestPath <- createNewLink imageDate srcPath + case mbDestPath of + (Just destPath) -> do + setExifDate imageDate destPath + setArtist destPath + Nothing -> pure () -- Get rid of anything not a regular file or with a number of links that @@ -51,33 +62,27 @@ -- Figure out and execute what the user wants based on the supplied args. main :: IO () main = do - opts <- parseOpts - - initLogging $ verbosity opts - - -- Notify user of the switches that will be in effect. - when opts.noAction.v $ - noticeM lname "No-action mode, nothing will be changed" + mapM_ (flip hSetBuffering NoBuffering) [stderr, stdout] + opts <- parseOpts + runRename (Env opts (logger . verbosity $ opts)) $ do + -- Notify user of the switches that will be in effect. + when opts.noAction.v $ + logNotice "No-action mode, nothing will be changed" - when opts.copy.v $ - noticeM lname "Files will be copied instead of the default of hard linking" + when opts.copy.v $ + logNotice "Files will be copied instead of the default of hard linking" - case opts.extension of - Extension ext -> noticeM lname $ formatToString ("The extension '" % string % "' will be used for all files") ext + case opts.extension of + Extension ext -> logNotice $ sformat ("The extension '" % string % "' will be used for all files") ext UseExistingExtension -> pure () - when opts.move.v $ - noticeM lname "Removing original links after new links are in place" + when opts.move.v $ + logNotice "Removing original links after new links are in place" - describeHardLinkPolicy $ links opts + describeHardLinkPolicy . links $ opts - actualPaths <- filterWantedFiles (links opts) (paths opts) + actualPaths <- liftIO $ filterWantedFiles (links opts) (paths opts) - -- Do the link manipulations, and report any errors. - forM_ actualPaths $ \srcPath -> do - result <- runRename opts $ processFile srcPath - either - (errorM lname . formatToString ("** Processing" %+ string % ":" %+ string) srcPath.v) - pure result + mapM_ processFile actualPaths - -- Perhaps we should get an ExitCode back from all this above? + -- logTest diff --git a/src/lib/Photoname/Common.hs b/src/lib/Photoname/Common.hs --- a/src/lib/Photoname/Common.hs +++ b/src/lib/Photoname/Common.hs @@ -12,50 +12,42 @@ , NoDirsSwitch (..) , ParentDir (..) , Options (..) - , Ph , Prefix (..) + , Severity (..) , SrcPath (..) , Suffix (..) , Verbosity (..) , defaultDateTimeFormat , 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 Colog.Simple (Severity (Debug, Info, Notice)) import Data.Time.LocalTime (LocalTime) -import System.Log.Logger (Priority (..)) import System.Posix (CNlink) defaultDateTimeFormat :: String defaultDateTimeFormat = "%Y%m%d-%H%M%S" + data Verbosity = Quiet - | Verbose Priority + | Verbose Severity instance Show Verbosity where show Quiet = "0" - show (Verbose NOTICE) = "1" - show (Verbose INFO) = "2" - show (Verbose DEBUG) = "3" + 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 "1" = Right $ Verbose Notice +readVerbosity "2" = Right $ Verbose Info +readVerbosity "3" = Right $ Verbose Debug readVerbosity _ = Left "Invalid verbosity level, expecting 0-3" @@ -104,10 +96,3 @@ newtype SrcPath = SrcPath { v :: FilePath } newtype DestPath = DestPath FilePath - - -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 --- a/src/lib/Photoname/CopyLink.hs +++ b/src/lib/Photoname/CopyLink.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE OverloadedRecordDot, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedRecordDot #-} module Photoname.CopyLink ( createNewLink ) where +import Colog.Simple (logNotice, logWarning) import Control.Exception (try) import Control.Monad (unless, when) import Data.Time.LocalTime (LocalTime) +import Formatting ((%+), sformat, string) + import GHC.IO.Exception (IOException) import System.Directory (copyFile, createDirectoryIfMissing) import System.FilePath ((), (<.>), takeDirectory, takeExtension) @@ -17,47 +20,57 @@ Extension (Extension, UseExistingExtension), MoveSwitch (v), NoActionSwitch (v), NoDirsSwitch (NoDirsSwitch), ParentDir (ParentDir), Options (copy, formatter, extension, move, noAction, noDirs, parentDir, prefix, suffix), - Ph, Prefix (Prefix), SrcPath (SrcPath), Suffix (Suffix), ask, asks, liftIO, - throwError) + Prefix (Prefix), SrcPath (SrcPath), Suffix (Suffix)) import Photoname.Date (PhDate (ExifDate, FilenameDate, NoDateFound), formatDateHyphens, formatYear) -import Photoname.Log (lname, noticeM, warningM) +import Photoname.Monad (Env (envOptions), Ph, asks, liftIO) -createNewLink :: PhDate -> SrcPath -> Ph DestPath -createNewLink imageDate srcPath@(SrcPath srcFp) = do - opts <- ask +createNewLink :: PhDate -> SrcPath -> Ph (Maybe DestPath) +createNewLink NoDateFound (SrcPath srcFp) = do + logWarning $ sformat ("Could not extract any date information from" %+ string) srcFp + pure Nothing + +createNewLink (ExifDate lt) srcPath = createNewLink' srcPath lt + +createNewLink (FilenameDate lt) srcPath = createNewLink' srcPath lt + + +createNewLink' :: SrcPath -> LocalTime -> Ph (Maybe DestPath) +createNewLink' srcPath@(SrcPath srcFp) lt = do + opts <- asks envOptions + let ext = case opts.extension of (Extension ext') -> ext' UseExistingExtension -> takeExtension srcFp - destPath@(DestPath destFp) <- case imageDate of - ExifDate lt -> buildDatePath lt ext - FilenameDate lt -> buildDatePath lt ext - NoDateFound -> throwError "Could not extract any date information" + destPath@(DestPath destFp) <- buildDatePath lt ext -- Check for existence of the target file - exists <- liftIO $ fileExist destFp - when exists $ throwError $ "Destination " ++ destFp ++ " exists!" - - -- Display what will be done - liftIO $ noticeM lname $ srcFp ++ " -> " ++ destFp + targetExists <- liftIO $ fileExist destFp + if targetExists + then do + logWarning $ sformat ("Destination" %+ string %+ "exists!") destFp + pure Nothing + else do + -- Display what will be done + logNotice $ sformat (string %+ "->" %+ string) srcFp destFp - unless opts.noAction.v $ do - -- Make the target dir - liftIO $ createDirectoryIfMissing True $ takeDirectory destFp + unless opts.noAction.v $ do + -- Make the target dir + liftIO $ createDirectoryIfMissing True $ takeDirectory destFp - -- Make the new file - if opts.copy.v - then liftIO $ copyFile srcFp destFp - else tryHardLink srcPath destPath + -- Make the new file + if opts.copy.v + then liftIO $ copyFile srcFp destFp + else tryHardLink srcPath destPath - -- If user has specified, remove the original link - when opts.move.v $ - liftIO $ removeLink srcFp + -- If user has specified, remove the original link + when opts.move.v $ + liftIO $ removeLink srcFp - pure destPath + pure $ Just destPath tryHardLink :: SrcPath -> DestPath -> Ph () @@ -67,7 +80,7 @@ where failureHandler :: IOException -> Ph () failureHandler _ = do - liftIO $ warningM lname "Hard link failed, attempting to copy instead" + logWarning "Hard link failed, attempting to copy instead" liftIO $ copyFile srcFp destFp @@ -77,13 +90,13 @@ -} buildDatePath :: LocalTime -> FilePath -> Ph DestPath buildDatePath date ext = do - (Prefix prefixStr) <- asks prefix - (Suffix suffixStr) <- asks suffix - dateFormatter <- asks formatter + (Prefix prefixStr) <- asks $ prefix . envOptions + (Suffix suffixStr) <- asks $ suffix . envOptions + dateFormatter <- asks $ formatter . envOptions let fileName = prefixStr <> dateFormatter date <> suffixStr - (ParentDir parentDir') <- asks parentDir - (NoDirsSwitch noDirs') <- asks noDirs + (ParentDir parentDir') <- asks $ parentDir . envOptions + (NoDirsSwitch noDirs') <- asks $ noDirs . envOptions pure . DestPath $ if noDirs' then parentDir' fileName <.> ext else parentDir' formatYear date diff --git a/src/lib/Photoname/Date.hs b/src/lib/Photoname/Date.hs --- a/src/lib/Photoname/Date.hs +++ b/src/lib/Photoname/Date.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -{-# LANGUAGE FlexibleContexts #-} module Photoname.Date ( PhDate (..) diff --git a/src/lib/Photoname/Exif.hs b/src/lib/Photoname/Exif.hs --- a/src/lib/Photoname/Exif.hs +++ b/src/lib/Photoname/Exif.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - module Photoname.Exif ( getExifDate ) diff --git a/src/lib/Photoname/Exiv2.hs b/src/lib/Photoname/Exiv2.hs --- a/src/lib/Photoname/Exiv2.hs +++ b/src/lib/Photoname/Exiv2.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Photoname.Exiv2 ( getExifDateWithExiv2 , setArtist @@ -7,23 +5,27 @@ ) where +import Colog.Simple (logDebug, logInfo, logNotice) import Control.Exception import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO) import Data.Char (isSpace) import Data.Monoid (First (..)) -import Formatting ((%), (%+), formatToString, string) +import Data.Text (Text) +import Data.Text qualified as TS +import Formatting ((%), (%+), formatToString, string, text) import GHC.IO.Exception import System.Process hiding (proc) import qualified System.Process as Proc import Photoname.Common (Artist (Artist), DestPath (DestPath), - NoActionSwitch (NoActionSwitch), Options (artist, noAction), Ph, - SrcPath (SrcPath), asks, liftIO) + NoActionSwitch (NoActionSwitch), Options (artist, noAction), + SrcPath (SrcPath)) import Photoname.Date (PhDate (FilenameDate), formatDateForExif) -import Photoname.Log (LogFunction, debugM, infoM, lname, noticeM) +import Photoname.Monad (Env (envOptions), Ph, asks, liftIO) +type LogFunction = Text -> Ph () + data Reading data Writing @@ -37,9 +39,9 @@ -- System.Process.proc BUT they look odd when logged by our code. This function -- will put quotes around any space-containing arguments purely for human -- readability. -commandToString :: Command rw -> String -commandToString (Command _ program' arguments) = - unwords $ program' : map quoteAsNeeded arguments +commandToText :: Command rw -> Text +commandToText (Command _ program' arguments) = + TS.pack . unwords $ program' : map quoteAsNeeded arguments where quoteAsNeeded str = if ' ' `elem` str then "'" <> str <> "'" @@ -49,25 +51,24 @@ proc (Command _ program' arguments) = Proc.proc program' arguments -logCommand :: MonadIO m => Command rw -> m () +logCommand :: Command rw -> Ph () logCommand command@(Command logFunction _ _) = - liftIO . logFunction lname . commandToString $ command - + logFunction . commandToText $ command -- For Writing (or "destructive") commands, we need to check if the user has -- chosen no-action behavior before executing -execWritingCommand :: Command Writing -> Ph (Either String String) +execWritingCommand :: Command Writing -> Ph (Maybe String) execWritingCommand command = do logCommand command - (NoActionSwitch noAction') <- asks noAction + (NoActionSwitch noAction') <- asks $ noAction . envOptions if noAction' - then pure $ Left "" + then pure Nothing else execCommand command -- For Reading (or "non-destructive") commands, we just log it and do it -execReadingCommand :: Command Reading -> Ph (Either String String) +execReadingCommand :: Command Reading -> Ph (Maybe String) execReadingCommand command = logCommand command >> execCommand command @@ -75,12 +76,19 @@ stripTrailingWhitespace = reverse . dropWhile isSpace . reverse -execCommand :: Command rw -> Ph (Either String String) -execCommand command = liftIO $ do - eResult <- postProcess =<< try (readCreateProcessWithExitCode (proc command) "") - either (\msg -> debugM lname $ "** Command failed: " <> stripTrailingWhitespace msg) - (\output -> debugM lname $ "Command succeeded, output: " <> stripTrailingWhitespace output) eResult - pure eResult +execCommand :: Command rw -> Ph (Maybe String) +execCommand command = do + eResult <- liftIO $ postProcess =<< try (readCreateProcessWithExitCode (proc command) "") + either handleFailure handleSuccess eResult + where + handleFailure msg = do + let msg' = formatToString (text %+ string) "** Command failed:" (stripTrailingWhitespace msg) + logDebug . TS.pack $ msg' + pure Nothing + handleSuccess output = do + let output' = formatToString (text %+ string) "Command succeeded, output:" (stripTrailingWhitespace output) + logDebug . TS.pack $ output' + pure . Just $ output' program :: FilePath @@ -97,14 +105,14 @@ setArtist :: DestPath -> Ph () setArtist (DestPath destFp) = do - artist' <- asks artist + artist' <- asks $ artist . envOptions case artist' of Nothing -> pure () Just (Artist "") -> void $ execWritingCommand $ - Command noticeM program ["--Modify", "del Exif.Image.Artist", destFp] + Command logNotice program ["--Modify", "del Exif.Image.Artist", destFp] Just (Artist artistInfo) -> void $ execWritingCommand $ - Command noticeM program ["--Modify", "set Exif.Image.Artist " <> artistInfo, destFp] + Command logNotice program ["--Modify", "set Exif.Image.Artist " <> artistInfo, destFp] getExifDateWithExiv2 :: SrcPath -> Ph (Maybe String) @@ -118,15 +126,14 @@ ["Exif.Photo.DateTimeOriginal", "Exif.Photo.DateTimeDigitized", "Exif.Image.DateTime"] where - mbResult tag = do - eResult <- execReadingCommand $ Command infoM program ["--Print", "v", "--grep", tag, srcFp] - pure . either (const Nothing) Just $ eResult + mbResult tag = + execReadingCommand $ Command logInfo program ["--Print", "v", "--grep", tag, srcFp] setExifDate :: PhDate -> DestPath -> Ph () setExifDate (FilenameDate lt) (DestPath destFp) = - void $ execWritingCommand . Command noticeM program $ + void $ execWritingCommand . Command logNotice program $ [ "--Modify", "set Exif.Image.DateTime Ascii " <> formatDateForExif lt , "--Modify", "set Exif.Photo.UserComment charset=Ascii DateTime is a guess", destFp ] diff --git a/src/lib/Photoname/Links.hs b/src/lib/Photoname/Links.hs --- a/src/lib/Photoname/Links.hs +++ b/src/lib/Photoname/Links.hs @@ -1,16 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} - module Photoname.Links ( describeHardLinkPolicy , linksTest ) where -import Formatting ((%+), formatToString, int) +import Colog.Simple (logNotice) +import Formatting ((%+), sformat, int) import System.Posix (FileStatus, linkCount) import Photoname.Common (Links (Exactly, NoLimit)) -import Photoname.Log (lname, noticeM) +import Photoname.Monad (Ph) linksTest :: Links -> FileStatus -> Bool @@ -18,10 +17,9 @@ linksTest NoLimit _ = True -describeHardLinkPolicy :: Links -> IO () +describeHardLinkPolicy :: Links -> Ph () describeHardLinkPolicy l = case l of - Exactly 1 -> noticeM lname "Only processing files with 1 hard link" - Exactly n -> noticeM lname $ formatToString + Exactly 1 -> logNotice "Only processing files with 1 hard link" + Exactly n -> logNotice $ sformat ("Only processing files with" %+ int %+ "hard links") (toInteger n) NoLimit -> pure () - diff --git a/src/lib/Photoname/Log.hs b/src/lib/Photoname/Log.hs --- a/src/lib/Photoname/Log.hs +++ b/src/lib/Photoname/Log.hs @@ -1,64 +1,18 @@ module Photoname.Log - ( LogFunction - , initLogging - , lname - , logTest - - -- Re-exported from System.Log - , debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM + ( logger ) where -import Data.Functor ((<&>)) -import System.IO (Handle, stdout) -import System.Log.Formatter (simpleLogFormatter) -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple (GenericHandler, streamHandler) -import System.Log.Logger - ( Priority (DEBUG) - , alertM, criticalM, debugM, emergencyM, errorM, infoM, noticeM, warningM - , rootLoggerName, setHandlers, setLevel, updateGlobalLogger - ) - -import Photoname.Common (Verbosity (Quiet, Verbose)) - - -type LogFunction = String -> String -> IO () - - -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 [] - --- Under the maximum verbosity (-v3), also display the logging Priority -handlers (Verbose DEBUG) = do - h <- streamHandler stdout DEBUG <&> - flip setFormatter (simpleLogFormatter "$prio: $msg") - pure [h] +import Colog.Simple (LogAction, Message, Severity(Debug), (%), (%+), msg, msgc, + sevc, stack, logTextStdout) +import Colog.Simple qualified +import Control.Monad.Trans (MonadIO) -handlers (Verbose _) = sequence [streamHandler stdout DEBUG] +import Photoname.Common (Verbosity (..)) --- 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" +-- Wrapper to set up logging based on desired verbosity +logger :: MonadIO m => Verbosity -> LogAction m Message +logger Quiet = mempty +logger (Verbose Debug) = Colog.Simple.logger (sevc % stack %+ msg) logTextStdout Debug +logger (Verbose sev) = Colog.Simple.logger msgc logTextStdout sev diff --git a/src/lib/Photoname/Monad.hs b/src/lib/Photoname/Monad.hs new file mode 100644 --- /dev/null +++ b/src/lib/Photoname/Monad.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Photoname.Monad + ( Env (..) + , Ph + , runRename + + -- Re-exporting: + , ask, asks + , liftIO + ) + where + +import Colog.Simple (HasLog (..), LogAction, Message) +import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT) +import Control.Monad.Trans (MonadIO, liftIO) + +import Photoname.Common (Options) + + +data Env m = Env + { envOptions :: !Options + , envLogAction :: !(LogAction m Message) + } + +instance HasLog (Env m) Message m where + getLogAction :: Env m -> LogAction m Message + getLogAction = envLogAction + {-# INLINE getLogAction #-} + + setLogAction :: LogAction m Message -> Env m -> Env m + setLogAction newLogAction env = env { envLogAction = newLogAction } + {-# INLINE setLogAction #-} + + +newtype Ph a = Ph { unPh :: ReaderT (Env Ph) IO a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Env Ph)) + +runRename :: Env Ph -> Ph a -> IO a +runRename env action = runReaderT (unPh action) env diff --git a/src/tests/Photoname/Test/EndToEnd/Link.hs b/src/tests/Photoname/Test/EndToEnd/Link.hs --- a/src/tests/Photoname/Test/EndToEnd/Link.hs +++ b/src/tests/Photoname/Test/EndToEnd/Link.hs @@ -46,7 +46,7 @@ testLinkDigitized = testCase "tests for DateTimeDigitized" $ do -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ parentDir, oldPath ] + [ "--parent-dir=" <> parentDir, oldPath ] waitForProcess procH -- Check that the correct output path exists @@ -71,7 +71,7 @@ -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ parentDir, digitizedOldPath ] + [ "--parent-dir=" <> parentDir, digitizedOldPath ] waitForProcess procH -- Check that the correct output path exists @@ -97,7 +97,7 @@ -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ parentDir, dateOldPath ] + [ "--parent-dir=" <> parentDir, dateOldPath ] waitForProcess procH -- Check that the correct output path exists @@ -120,12 +120,12 @@ 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" ] + [ "--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) + (output =~ ("Could not extract any date information from util/resources/test/noDate.jpg" :: String) :: Bool) testMove :: TestTree @@ -137,7 +137,7 @@ -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--move", "--parent-dir=" ++ parentDir, newOldPath ] + [ "--move", "--parent-dir=" <> parentDir, newOldPath ] waitForProcess procH -- Check that the correct output path exists @@ -168,19 +168,19 @@ testLinkNoAction' label switch = testCase label $ do -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ switch, "--parent-dir=" ++ parentDir, oldPath ] + [ 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 + Util.assertFalse (label <> ": existence of new link") existsNew -- Check that old path still exists existsOld <- fileExist oldPath - assertBool (label ++ ": existence of old link") existsOld + assertBool (label <> ": existence of old link") existsOld -- Test output to stdout - assertBool (label ++ ": correct output") + assertBool (label <> ": correct output") (output =~ newLinkPathDate :: Bool) @@ -197,22 +197,22 @@ testLinkQuiet' label switch = testCase label $ do -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ switch, "--parent-dir=" ++ parentDir, oldPath ] + [ switch, "--parent-dir=" <> parentDir, oldPath ] waitForProcess procH -- Check that the correct output path exists existsNew <- fileExist newLinkPathDate - assertBool (label ++ ": existence of new link") existsNew + assertBool (label <> ": existence of new link") existsNew -- Check that old path still exists existsOld <- fileExist oldPath - assertBool (label ++ ": existence of old link") existsOld + 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") + Util.assertFalse (label <> ": no output") (output =~ newLinkPathDate :: Bool) @@ -222,11 +222,11 @@ -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ parentDir, "--suffix=" ++ suffix, oldPath ] + [ "--parent-dir=" <> parentDir, "--suffix=" <> suffix, oldPath ] waitForProcess procH let newLinkPath = parentDir - ("2003/2003-09-02/20030902-114303" ++ suffix) <.> "jpg" + ("2003/2003-09-02/20030902-114303" <> suffix) <.> "jpg" -- Check that the correct output path exists existsNew <- fileExist newLinkPath @@ -250,7 +250,7 @@ -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ parentDir, "--prefix=" ++ prefix, oldPath ] + [ "--parent-dir=" <> parentDir, "--prefix=" <> prefix, oldPath ] waitForProcess procH let newLinkPath = parentDir @@ -276,36 +276,36 @@ 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" ] + [ "--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) + (output =~ ("Could not extract any date information from util/resources/test/noExif.jpg" :: String) :: 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" ] + [ "--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) + (output =~ ("Could not extract any date information from util/resources/test/notAnImage.txt" :: String) :: 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 ] + [ "--parent-dir=" <> parentDir, Util.resourcesPath ] waitForProcess procH -- Test output to stdout assertBool "dir as file to change: correct output" - (output =~ "" :: Bool) + (output =~ ("" :: String) :: Bool) testLinkFilenameDate :: TestTree @@ -318,7 +318,7 @@ -- Run the program with known input data (output, procH) <- Util.getBinaryOutput - [ "--parent-dir=" ++ parentDir, newOldPath ] + [ "--parent-dir=" <> parentDir, newOldPath ] waitForProcess procH -- Check that the correct output path exists diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,10 @@ -resolver: lts-21.25 +snapshot: lts-22.6 packages: - . extra-deps: -- hsexif-0.6.1.10 +- co-log-simple-1.1.0 flags: hsexif: diff --git a/stack.yaml.lock b/stack.yaml.lock --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -1,19 +1,19 @@ # 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 +# https://docs.haskellstack.org/en/stable/topics/lock_files packages: - completed: - hackage: hsexif-0.6.1.10@sha256:f002993b7953186a9e13869efe830ce951b900ee504afdbc297950f3b88fc3e3,2276 + hackage: co-log-simple-1.1.0@sha256:8cc7c99d60d0c6088e76e2548f7621737ae7e26f1237c181ead009ee9763c951,1767 pantry-tree: - sha256: 25066251bd371301fa2d8e693d5e84828ceee2a02e2ee7f1523065fc2cbf72db - size: 1120 + sha256: 918c592895abf6aeb758343c9c9090b3c92ba20b31f2e24f53b7f62aa572b5a0 + size: 579 original: - hackage: hsexif-0.6.1.10 + hackage: co-log-simple-1.1.0 snapshots: - completed: - sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd - size: 640086 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml - original: lts-21.25 + sha256: 1b4c2669e26fa828451830ed4725e4d406acc25a1fa24fcc039465dd13d7a575 + size: 714100 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/6.yaml + original: lts-22.6