Exiv2.hs

module Photoname.Exiv2
  ( getExifDateWithExiv2
  , setArtist
  , setExifDate
  )
  where

import Colog.Simple (logDebug, logInfo, logNotice)
import Control.Exception
import Control.Monad (void)
import Data.Char (isSpace)
import Data.Monoid (First (..))
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),
  SrcPath (SrcPath))
import Photoname.Date (PhDate (FilenameDate), formatDateForExif)
import Photoname.Monad (Env (envOptions), Ph, asks, liftIO)


type LogFunction = Text -> Ph ()

data Reading
data Writing

-- For logging purposes we keep the program name separate from its arguments
-- until we need to build a CreateProcess data structure
data Command rw = Command LogFunction FilePath [String]

-- Construct a human-readable command-line from a Command data structure. This
-- is purely for logging.
-- Arguments may contain spaces but be quoted properly when this is used by
-- System.Process.proc BUT they look odd when logged by our code. This function
-- will put quotes around any space-containing arguments purely for human
-- readability.
commandToText :: Command rw -> Text
commandToText (Command _ program' arguments) =
  TS.pack . unwords $ program' : map quoteAsNeeded arguments
  where
    quoteAsNeeded str = if ' ' `elem` str
      then "'" <> str <> "'"
      else str

proc :: Command rw -> CreateProcess
proc (Command _ program' arguments) = Proc.proc program' arguments


logCommand :: Command rw -> Ph ()
logCommand command@(Command logFunction _ _) =
  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 (Maybe String)
execWritingCommand command = do
  logCommand command
  (NoActionSwitch noAction') <- asks $ noAction . envOptions
  if noAction'
    then pure Nothing
    else execCommand command


-- For Reading (or "non-destructive") commands, we just log it and do it
execReadingCommand :: Command Reading -> Ph (Maybe String)
execReadingCommand command = logCommand command >> execCommand command


stripTrailingWhitespace :: String -> String
stripTrailingWhitespace = reverse . dropWhile isSpace . reverse


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
program = "exiv2"


postProcess :: Either IOException (ExitCode, String, String) -> IO (Either String String)
postProcess (Left   e                             ) =
  pure . Left $ formatToString (string % ":" %+ string) program (ioe_description e)
postProcess (Right (ExitSuccess  , stdOut, _     )) = pure . Right $ stdOut
postProcess (Right (ExitFailure 1, _     , ""    )) = pure . Left $ "EXIF tag not found"
postProcess (Right (ExitFailure _, _     , stdErr)) = pure . Left $ stdErr


setArtist :: DestPath -> Ph ()
setArtist (DestPath destFp) = do
  artist' <- asks $ artist . envOptions

  case artist' of
    Nothing -> pure ()
    Just (Artist "") -> void $ execWritingCommand $
      Command logNotice program ["--Modify", "del Exif.Image.Artist", destFp]
    Just (Artist artistInfo) -> void $ execWritingCommand $
      Command logNotice program ["--Modify", "set Exif.Image.Artist " <> artistInfo, destFp]


getExifDateWithExiv2 :: SrcPath -> Ph (Maybe String)
getExifDateWithExiv2 (SrcPath srcFp) =
  getFirst  -- Remove the First wrapper
  . mconcat  -- Collapse these to the first not-Nothing
  . map First -- Wrap in First data structures
  -- Look up all of them (resulting in Ph [Maybe ExifValue])
  <$> mapM mbResult
  -- EXIF tags we're intersted in, in the order we want them left-to-right
  ["Exif.Photo.DateTimeOriginal", "Exif.Photo.DateTimeDigitized", "Exif.Image.DateTime"]

  where
    mbResult tag =
      execReadingCommand $ Command logInfo program ["--Print", "v", "--grep", tag, srcFp]


setExifDate :: PhDate -> DestPath -> Ph ()

setExifDate (FilenameDate lt) (DestPath destFp) =
  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
    ]

setExifDate _ _ = pure ()