{-# LANGUAGE OverloadedStrings #-}

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

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 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)
import Photoname.Date (PhDate (FilenameDate), formatDateForExif)
import Photoname.Log (LogFunction, debugM, infoM, lname, noticeM)


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.
commandToString :: Command rw -> String
commandToString :: forall rw. Command rw -> String
commandToString (Command LogFunction
_ String
program' [String]
arguments) =
  [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
program' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall {t :: * -> *}.
(Foldable t, Semigroup (t Char), IsString (t Char)) =>
t Char -> t Char
quoteAsNeeded [String]
arguments
  where
    quoteAsNeeded :: t Char -> t Char
quoteAsNeeded t Char
str = if Char
' ' Char -> t Char -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
str
      then t Char
"'" t Char -> t Char -> t Char
forall a. Semigroup a => a -> a -> a
<> t Char
str t Char -> t Char -> t Char
forall a. Semigroup a => a -> a -> a
<> t Char
"'"
      else t Char
str

proc :: Command rw -> CreateProcess
proc :: forall rw. Command rw -> CreateProcess
proc (Command LogFunction
_ String
program' [String]
arguments) = String -> [String] -> CreateProcess
Proc.proc String
program' [String]
arguments


logCommand :: MonadIO m => Command rw -> m ()
logCommand :: forall (m :: * -> *) rw. MonadIO m => Command rw -> m ()
logCommand command :: Command rw
command@(Command LogFunction
logFunction String
_ [String]
_) =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Command rw -> IO ()) -> Command rw -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunction
logFunction String
lname (String -> IO ()) -> (Command rw -> String) -> Command rw -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command rw -> String
forall rw. Command rw -> String
commandToString (Command rw -> m ()) -> Command rw -> m ()
forall a b. (a -> b) -> a -> b
$ Command rw
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 (Either String String)
execWritingCommand Command Writing
command = do
  Command Writing -> ReaderT Options (ExceptT String IO) ()
forall (m :: * -> *) rw. MonadIO m => Command rw -> m ()
logCommand Command Writing
command
  (NoActionSwitch Bool
noAction') <- (Options -> NoActionSwitch)
-> ReaderT Options (ExceptT String IO) NoActionSwitch
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> NoActionSwitch
noAction
  if Bool
noAction'
    then Either String String -> Ph (Either String String)
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> Ph (Either String String))
-> Either String String -> Ph (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
""
    else Command Writing -> Ph (Either String String)
forall rw. Command rw -> Ph (Either String String)
execCommand Command Writing
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 (Either String String)
execReadingCommand Command Reading
command = Command Reading -> ReaderT Options (ExceptT String IO) ()
forall (m :: * -> *) rw. MonadIO m => Command rw -> m ()
logCommand Command Reading
command ReaderT Options (ExceptT String IO) ()
-> Ph (Either String String) -> Ph (Either String String)
forall a b.
ReaderT Options (ExceptT String IO) a
-> ReaderT Options (ExceptT String IO) b
-> ReaderT Options (ExceptT String IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Command Reading -> Ph (Either String String)
forall rw. Command rw -> Ph (Either String String)
execCommand Command Reading
command


stripTrailingWhitespace :: String -> String
stripTrailingWhitespace :: String -> String
stripTrailingWhitespace = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse


execCommand :: Command rw -> Ph (Either String String)
execCommand :: forall rw. Command rw -> Ph (Either String String)
execCommand Command rw
command = IO (Either String String) -> Ph (Either String String)
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String) -> Ph (Either String String))
-> IO (Either String String) -> Ph (Either String String)
forall a b. (a -> b) -> a -> b
$ do
  Either String String
eResult <- Either IOException (ExitCode, String, String)
-> IO (Either String String)
postProcess (Either IOException (ExitCode, String, String)
 -> IO (Either String String))
-> IO (Either IOException (ExitCode, String, String))
-> IO (Either String String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (ExitCode, String, String)
-> IO (Either IOException (ExitCode, String, String))
forall e a. Exception e => IO a -> IO (Either e a)
try (CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode (Command rw -> CreateProcess
forall rw. Command rw -> CreateProcess
proc Command rw
command) String
"")
  (String -> IO ())
-> (String -> IO ()) -> Either String String -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
msg -> LogFunction
debugM String
lname (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"** Command failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
stripTrailingWhitespace String
msg)
    (\String
output -> LogFunction
debugM String
lname (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Command succeeded, output: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
stripTrailingWhitespace String
output) Either String String
eResult
  Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String String
eResult


program :: FilePath
program :: String
program = String
"exiv2"


postProcess :: Either IOException (ExitCode, String, String) -> IO (Either String String)
postProcess :: Either IOException (ExitCode, String, String)
-> IO (Either String String)
postProcess (Left   IOException
e                             ) =
  Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ Format String (String -> String -> String)
-> String -> String -> String
forall a. Format String a -> a
formatToString (Format (String -> String) (String -> String -> String)
forall r. Format r (String -> r)
string Format (String -> String) (String -> String -> String)
-> Format String (String -> String)
-> Format String (String -> String -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (String -> String) (String -> String)
":" Format (String -> String) (String -> String)
-> Format String (String -> String)
-> Format String (String -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (String -> String)
forall r. Format r (String -> r)
string) String
program (IOException -> String
ioe_description IOException
e)
postProcess (Right (ExitCode
ExitSuccess  , String
stdOut, String
_     )) = Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. b -> Either a b
Right (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
stdOut
postProcess (Right (ExitFailure Int
1, String
_     , String
""    )) = Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
"EXIF tag not found"
postProcess (Right (ExitFailure Int
_, String
_     , String
stdErr)) = Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
stdErr


setArtist :: DestPath -> Ph ()
setArtist :: DestPath -> ReaderT Options (ExceptT String IO) ()
setArtist (DestPath String
destFp) = do
  Maybe Artist
artist' <- (Options -> Maybe Artist)
-> ReaderT Options (ExceptT String IO) (Maybe Artist)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Maybe Artist
artist

  case Maybe Artist
artist' of
    Maybe Artist
Nothing -> () -> ReaderT Options (ExceptT String IO) ()
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Artist String
"") -> Ph (Either String String) -> ReaderT Options (ExceptT String IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ph (Either String String)
 -> ReaderT Options (ExceptT String IO) ())
-> Ph (Either String String)
-> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ Command Writing -> Ph (Either String String)
execWritingCommand (Command Writing -> Ph (Either String String))
-> Command Writing -> Ph (Either String String)
forall a b. (a -> b) -> a -> b
$
      LogFunction -> String -> [String] -> Command Writing
forall rw. LogFunction -> String -> [String] -> Command rw
Command LogFunction
noticeM String
program [String
"--Modify", String
"del Exif.Image.Artist", String
destFp]
    Just (Artist String
artistInfo) -> Ph (Either String String) -> ReaderT Options (ExceptT String IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ph (Either String String)
 -> ReaderT Options (ExceptT String IO) ())
-> Ph (Either String String)
-> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ Command Writing -> Ph (Either String String)
execWritingCommand (Command Writing -> Ph (Either String String))
-> Command Writing -> Ph (Either String String)
forall a b. (a -> b) -> a -> b
$
      LogFunction -> String -> [String] -> Command Writing
forall rw. LogFunction -> String -> [String] -> Command rw
Command LogFunction
noticeM String
program [String
"--Modify", String
"set Exif.Image.Artist " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
artistInfo, String
destFp]


getExifDateWithExiv2 :: SrcPath -> Ph (Maybe String)
getExifDateWithExiv2 :: SrcPath -> Ph (Maybe String)
getExifDateWithExiv2 (SrcPath String
srcFp) =
  First String -> Maybe String
forall a. First a -> Maybe a
getFirst  -- Remove the First wrapper
  (First String -> Maybe String)
-> ([Maybe String] -> First String)
-> [Maybe String]
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [First String] -> First String
forall a. Monoid a => [a] -> a
mconcat  -- Collapse these to the first not-Nothing
  ([First String] -> First String)
-> ([Maybe String] -> [First String])
-> [Maybe String]
-> First String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> First String) -> [Maybe String] -> [First String]
forall a b. (a -> b) -> [a] -> [b]
map Maybe String -> First String
forall a. Maybe a -> First a
First -- Wrap in First data structures
  -- Look up all of them (resulting in Ph [Maybe ExifValue])
  ([Maybe String] -> Maybe String)
-> ReaderT Options (ExceptT String IO) [Maybe String]
-> Ph (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Ph (Maybe String))
-> [String] -> ReaderT Options (ExceptT String IO) [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Ph (Maybe String)
mbResult
  -- EXIF tags we're intersted in, in the order we want them left-to-right
  [String
"Exif.Photo.DateTimeOriginal", String
"Exif.Photo.DateTimeDigitized", String
"Exif.Image.DateTime"]

  where
    mbResult :: String -> Ph (Maybe String)
mbResult String
tag = do
      Either String String
eResult <- Command Reading -> Ph (Either String String)
execReadingCommand (Command Reading -> Ph (Either String String))
-> Command Reading -> Ph (Either String String)
forall a b. (a -> b) -> a -> b
$ LogFunction -> String -> [String] -> Command Reading
forall rw. LogFunction -> String -> [String] -> Command rw
Command LogFunction
infoM String
program [String
"--Print", String
"v", String
"--grep", String
tag, String
srcFp]
      Maybe String -> Ph (Maybe String)
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> Ph (Maybe String))
-> (Either String String -> Maybe String)
-> Either String String
-> Ph (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String)
-> (String -> Maybe String) -> Either String String -> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> String -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) String -> Maybe String
forall a. a -> Maybe a
Just (Either String String -> Ph (Maybe String))
-> Either String String -> Ph (Maybe String)
forall a b. (a -> b) -> a -> b
$ Either String String
eResult


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

setExifDate :: PhDate -> DestPath -> ReaderT Options (ExceptT String IO) ()
setExifDate (FilenameDate LocalTime
lt) (DestPath String
destFp) =
  Ph (Either String String) -> ReaderT Options (ExceptT String IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ph (Either String String)
 -> ReaderT Options (ExceptT String IO) ())
-> Ph (Either String String)
-> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ Command Writing -> Ph (Either String String)
execWritingCommand (Command Writing -> Ph (Either String String))
-> ([String] -> Command Writing)
-> [String]
-> Ph (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFunction -> String -> [String] -> Command Writing
forall rw. LogFunction -> String -> [String] -> Command rw
Command LogFunction
noticeM String
program ([String] -> Ph (Either String String))
-> [String] -> Ph (Either String String)
forall a b. (a -> b) -> a -> b
$
    [ String
"--Modify", String
"set Exif.Image.DateTime Ascii " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LocalTime -> String
formatDateForExif LocalTime
lt
    , String
"--Modify", String
"set Exif.Photo.UserComment charset=Ascii DateTime is a guess", String
destFp
    ]

setExifDate PhDate
_ DestPath
_ = () -> ReaderT Options (ExceptT String IO) ()
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()