{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module     : ExifTool
-- Copyright  : (c) Martin Hoppenheit 2020
-- License    : MIT
-- Maintainer : martin@hoppenheit.info
--
-- This module contains bindings to the [ExifTool](https://exiftool.org)
-- command-line application that enable reading, writing and deleting metadata
-- in various file formats. Here's a short code example, the details are
-- explained below.
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE OverloadedLists #-}
-- >
-- > import ExifTool
-- > import Data.HashMap.Strict ((!?))
-- >
-- > example :: IO ()
-- > example =
-- >     withExifTool $ \et -> do
-- >         -- Read metadata, with exact (!?) and fuzzy (~~) tag lookup.
-- >         m <- getMeta et "a.jpg"
-- >         print $ m !? Tag "EXIF" "ExifIFD" "DateTimeOriginal"
-- >         print $ m ~~ Tag "EXIF" "" "XResolution"
-- >         print $ m ~~ Tag "XMP" "" ""
-- >         -- Write and delete metadata.
-- >         setMeta et [(Tag "XMP" "XMP-dc" "Description", String "...")] "a.jpg"
-- >         deleteMeta et [Tag "XMP" "XMP-dc" "Description"] "a.jpg"
--
-- Note that this module expects the @exiftool@ binary to be in your PATH.

module ExifTool
    ( -- * Running an ExifTool instance
      --
      -- | Most functions in this module interact with an ExifTool instance
      -- i.e., a running ExifTool process represented by the 'ExifTool' data
      -- type. The easiest way to obtain an instance is the 'withExifTool'
      -- function that takes care of starting and stopping the process.
      ExifTool
    , startExifTool
    , stopExifTool
    , withExifTool
      -- * Reading and writing metadata
      --
      -- | The ExifTool instance can then be used to read, write or delete
      -- metadata in a file with the respective functions. These come in two
      -- variants, one that throws runtime errors when the ExifTool process
      -- returns error messages and one that instead produces Either values.
      -- Choose those that best fit your use case.
    , getMeta
    , setMeta
    , deleteMeta
    , getMetaEither
    , setMetaEither
    , deleteMetaEither
      -- * Data types and utility functions
      --
      -- | Metadata is represented by a 'Data.HashMap.Strict.HashMap' of
      -- 'Tag'/'Value' pairs (with alias 'Metadata'), so it is advisable to
      -- import some functions like 'Data.HashMap.Strict.lookup' or
      -- 'Data.HashMap.Strict.!?' from the "Data.HashMap.Strict" module. The
      -- ExifTool module defines additional utility functions that make working
      -- with Metadata easier.
    , Metadata
    , Tag(..)
    , Value(..)
    , filterByTag
    , (~~)
    ) where

import Control.Exception (bracket)
import Control.Monad (void)
import qualified Data.Aeson as JSON
import Data.Aeson
    ( FromJSON(..)
    , FromJSONKey(..)
    , FromJSONKeyFunction(..)
    , ToJSON(..)
    , ToJSONKey(..)
    , ToJSONKeyFunction(..)
    , eitherDecode
    , encode
    )
import Data.Aeson.Encoding.Internal (bool, list, scientific, text)
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (decodeBase64, encodeBase64)
import Data.ByteString.Lazy (hPut)
import Data.HashMap.Strict (HashMap, delete, filterWithKey, fromList)
import Data.Hashable (Hashable)
import Data.Scientific (Scientific)
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.IO (hGetLine, hPutStrLn)
import qualified Data.Vector as Vector
import GHC.Generics (Generic)
import System.IO (Handle, hFlush, hReady)
import System.IO.Temp (withSystemTempFile)
import System.Process
    ( ProcessHandle
    , StdStream(CreatePipe)
    , cleanupProcess
    , createProcess
    , proc
    , std_err
    , std_in
    , std_out
    )

-- | An ExifTool instance, initialized with 'startExifTool' and terminated with
-- 'stopExifTool'.
data ExifTool = ET
    !Handle        -- ^ STDIN of this ExifTool process
    !Handle        -- ^ STDOUT of this ExifTool process
    !Handle        -- ^ STDERR of this ExifTool process
    !ProcessHandle -- ^ process handle of this ExifTool process

-- | A set of ExifTool tag/value pairs.
type Metadata = HashMap Tag Value

-- | An ExifTool tag name, consisting of three components:
--
-- 1. The family 0 tag group (information type) e.g., @EXIF@ or @XMP@.
-- 2. The family 1 tag group (specific location) e.g., @IFD0@ or @XMP-dc@.
-- 3. The actual tag name e.g., @XResolution@ or @Description@.
--
-- Example: @Tag \"EXIF\" \"IFD0\" \"XResolution\"@ corresponds to the ExifTool
-- tag name @EXIF:IFD0:XResolution@.
--
-- During development, there are several ways to find the exact name of a tag:
--
-- * See <https://exiftool.org/#groups> for a list of tag groups.
-- * Run something like @exiftool -s -a -G:0:1@.
-- * Use the '~~' operator in ghci.
data Tag = Tag
    { Tag -> Text
tagFamily0 :: !Text -- ^ family 0 tag group
    , Tag -> Text
tagFamily1 :: !Text -- ^ family 1 tag group
    , Tag -> Text
tagName    :: !Text -- ^ actual tag name
    } deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, (forall x. Tag -> Rep Tag x)
-> (forall x. Rep Tag x -> Tag) -> Generic Tag
forall x. Rep Tag x -> Tag
forall x. Tag -> Rep Tag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Tag x -> Tag
$cfrom :: forall x. Tag -> Rep Tag x
Generic, Int -> Tag -> Int
Tag -> Int
(Int -> Tag -> Int) -> (Tag -> Int) -> Hashable Tag
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Tag -> Int
$chash :: Tag -> Int
hashWithSalt :: Int -> Tag -> Int
$chashWithSalt :: Int -> Tag -> Int
Hashable)

instance FromJSON Tag where
    parseJSON :: Value -> Parser Tag
parseJSON (JSON.String x :: Text
x)
        | Just t :: Tag
t <- Text -> Maybe Tag
readTag Text
x = Tag -> Parser Tag
forall (m :: * -> *) a. Monad m => a -> m a
return Tag
t
    parseJSON x :: Value
x = String -> Parser Tag
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Tag) -> String -> Parser Tag
forall a b. (a -> b) -> a -> b
$ "unexpected formatting of ExifTool tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

instance FromJSONKey Tag where
    fromJSONKey :: FromJSONKeyFunction Tag
fromJSONKey = (Text -> Parser Tag) -> FromJSONKeyFunction Tag
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser Tag) -> FromJSONKeyFunction Tag)
-> (Text -> Parser Tag) -> FromJSONKeyFunction Tag
forall a b. (a -> b) -> a -> b
$ Value -> Parser Tag
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Tag) -> (Text -> Value) -> Text -> Parser Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
JSON.String

instance ToJSON Tag where
    toJSON :: Tag -> Value
toJSON = Text -> Value
JSON.String (Text -> Value) -> (Tag -> Text) -> Tag -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
showTag
    toEncoding :: Tag -> Encoding
toEncoding = Text -> Encoding
forall a. Text -> Encoding' a
text (Text -> Encoding) -> (Tag -> Text) -> Tag -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
showTag

instance ToJSONKey Tag where
    toJSONKey :: ToJSONKeyFunction Tag
toJSONKey = (Tag -> Text) -> (Tag -> Encoding' Text) -> ToJSONKeyFunction Tag
forall a.
(a -> Text) -> (a -> Encoding' Text) -> ToJSONKeyFunction a
ToJSONKeyText Tag -> Text
showTag (Text -> Encoding' Text
forall a. Text -> Encoding' a
text (Text -> Encoding' Text) -> (Tag -> Text) -> Tag -> Encoding' Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
showTag)

-- | Parse an ExifTool tag name of the form @family0:family1:name@,
-- @family0:name@ or @name@ (but /not/ @family1:name@).
readTag :: Text -> Maybe Tag
readTag :: Text -> Maybe Tag
readTag t :: Text
t =
    case Text -> Text -> [Text]
T.splitOn ":" Text
t of
        [f0 :: Text
f0, f1 :: Text
f1, n :: Text
n] -> Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Tag
Tag Text
f0 Text
f1 Text
n
        [f0 :: Text
f0, n :: Text
n] -> Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Tag
Tag Text
f0 "" Text
n
        [n :: Text
n] -> Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Tag
Tag "" "" Text
n
        _ -> Maybe Tag
forall a. Maybe a
Nothing

-- | Format an ExifTool tag name in the form @family0:family1:name@,
-- @family0:name@, @family1:name@ or @name@.
showTag :: Tag -> Text
showTag :: Tag -> Text
showTag (Tag f0 :: Text
f0 f1 :: Text
f1 n :: Text
n) = Text -> [Text] -> Text
T.intercalate ":" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) [Text
f0, Text
f1, Text
n]

-- | An ExifTool tag value, enclosed in a type wrapper.
data Value
    = String !Text
    | Binary !ByteString
    | Number !Scientific
    | Bool   !Bool
    | List   ![Value]
    -- Struct (Map Text Value)
    deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq)

instance FromJSON Value where
    parseJSON :: Value -> Parser Value
parseJSON (JSON.String x :: Text
x)
        | Just b :: Text
b <- Text -> Text -> Maybe Text
T.stripPrefix "base64:" Text
x =
            (Text -> Parser Value)
-> (ByteString -> Parser Value)
-> Either Text ByteString
-> Parser Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Value)
-> (Text -> String) -> Text -> Parser Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs) (Value -> Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Parser Value)
-> (ByteString -> Value) -> ByteString -> Parser Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Value
Binary) (ByteString -> Either Text ByteString
decodeBase64 (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
b)
        | Bool
otherwise = Value -> Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
x
    parseJSON (JSON.Number x :: Scientific
x) = Value -> Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number Scientific
x
    parseJSON (JSON.Bool x :: Bool
x) = Value -> Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Bool Bool
x
    parseJSON (JSON.Array xs :: Array
xs) =
        [Value] -> Value
List ([Value] -> Value) -> Parser [Value] -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser Value] -> Parser [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Vector (Parser Value) -> [Parser Value]
forall a. Vector a -> [a]
Vector.toList (Vector (Parser Value) -> [Parser Value])
-> Vector (Parser Value) -> [Parser Value]
forall a b. (a -> b) -> a -> b
$ (Value -> Parser Value) -> Array -> Vector (Parser Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Parser Value
forall a. FromJSON a => Value -> Parser a
parseJSON Array
xs)
    parseJSON JSON.Null = Value -> Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String ""
    -- parseJSON (JSON.Object x) = Struct <$> sequence (fmap parseJSON x)
    parseJSON x :: Value
x = String -> Parser Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Value) -> String -> Parser Value
forall a b. (a -> b) -> a -> b
$ "error parsing ExifTool JSON output: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

instance ToJSON Value where
    toJSON :: Value -> Value
toJSON (String x :: Text
x) = Text -> Value
JSON.String Text
x
    toJSON (Binary x :: ByteString
x) = Text -> Value
JSON.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ "base64:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
encodeBase64 ByteString
x
    toJSON (Number x :: Scientific
x) = Scientific -> Value
JSON.Number Scientific
x
    toJSON (Bool x :: Bool
x) = Bool -> Value
JSON.Bool Bool
x
    toJSON (List xs :: [Value]
xs) = Array -> Value
JSON.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Value
forall a. ToJSON a => a -> Value
toJSON [Value]
xs
    toEncoding :: Value -> Encoding
toEncoding (String x :: Text
x) = Text -> Encoding
forall a. Text -> Encoding' a
text Text
x
    toEncoding (Binary x :: ByteString
x) = Text -> Encoding
forall a. Text -> Encoding' a
text (Text -> Encoding) -> Text -> Encoding
forall a b. (a -> b) -> a -> b
$ "base64:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
encodeBase64 ByteString
x
    toEncoding (Number x :: Scientific
x) = Scientific -> Encoding
scientific Scientific
x
    toEncoding (Bool x :: Bool
x) = Bool -> Encoding
bool Bool
x
    toEncoding (List xs :: [Value]
xs) = (Value -> Encoding) -> [Value] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
list Value -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding [Value]
xs

-- | Start an ExifTool instance. Use 'stopExifTool' when done, or 'withExifTool'
-- to combine both steps.
startExifTool :: IO ExifTool
startExifTool :: IO ExifTool
startExifTool = do
    (Just i :: Handle
i, Just o :: Handle
o, Just e :: Handle
e, p :: ProcessHandle
p) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
conf
    ExifTool -> IO ExifTool
forall (m :: * -> *) a. Monad m => a -> m a
return (ExifTool -> IO ExifTool) -> ExifTool -> IO ExifTool
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Handle -> ProcessHandle -> ExifTool
ET Handle
i Handle
o Handle
e ProcessHandle
p
  where
    conf :: CreateProcess
conf =
        (String -> [String] -> CreateProcess
proc "exiftool" [String]
options)
            {std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe}
    options :: [String]
options = ["-stay_open", "True", "-@", "-"]

-- | Stop a running ExifTool instance.
stopExifTool :: ExifTool -> IO ()
stopExifTool :: ExifTool -> IO ()
stopExifTool (ET i :: Handle
i o :: Handle
o e :: Handle
e p :: ProcessHandle
p) = do
    Handle -> Text -> IO ()
hPutStrLn Handle
i "-stay_open"
    Handle -> Text -> IO ()
hPutStrLn Handle
i "False"
    Handle -> IO ()
hFlush Handle
i
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
i, Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
o, Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
e, ProcessHandle
p)

-- | Start an ExifTool instance, do something with it, then stop it.
withExifTool :: (ExifTool -> IO a) -> IO a
withExifTool :: (ExifTool -> IO a) -> IO a
withExifTool = IO ExifTool -> (ExifTool -> IO ()) -> (ExifTool -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ExifTool
startExifTool ExifTool -> IO ()
stopExifTool

-- | Send a sequence of command-line arguments to a running ExifTool instance
-- and return the corresponding output/errors.
--
-- The final @-execute@ argument is added automatically.
sendCommand :: ExifTool -> [Text] -> IO (Either Text Text)
sendCommand :: ExifTool -> [Text] -> IO (Either Text Text)
sendCommand (ET i :: Handle
i o :: Handle
o e :: Handle
e _) cmds :: [Text]
cmds = do
    (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
hPutStrLn Handle
i) [Text]
cmds
    Handle -> Text -> IO ()
hPutStrLn Handle
i "-execute"
    Handle -> IO ()
hFlush Handle
i
    -- Do not switch the order of readOut/readErr lest we miss errors!
    Text
out <- Handle -> Text -> IO Text
readOut Handle
o ""
    Text
err <- Handle -> Text -> IO Text
readErr Handle
e ""
    Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> IO (Either Text Text))
-> Either Text Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$
        if Text -> Bool
isError Text
err
            then Text -> Either Text Text
forall a b. a -> Either a b
Left Text
err
            else Text -> Either Text Text
forall a b. b -> Either a b
Right Text
out
  where
    -- | Read from handle up to the string @{ready}@.
    readOut :: Handle -> Text -> IO Text
    readOut :: Handle -> Text -> IO Text
readOut h :: Handle
h acc :: Text
acc = do
        Text
l <- Handle -> IO Text
hGetLine Handle
h
        if "{ready}" Text -> Text -> Bool
`T.isPrefixOf` Text
l
            then Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
acc
            else Handle -> Text -> IO Text
readOut Handle
h (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)
    -- | Read /currently/ available data from handle, don't wait for more.
    readErr :: Handle -> Text -> IO Text
    readErr :: Handle -> Text -> IO Text
readErr h :: Handle
h acc :: Text
acc = do
        Bool
hasMore <- Handle -> IO Bool
hReady Handle
h
        if Bool -> Bool
not Bool
hasMore
            then Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
acc
            else do
                Text
l <- Handle -> IO Text
hGetLine Handle
h
                Handle -> Text -> IO Text
readErr Handle
h (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)
    -- | Make sure an error string actually counts as error.
    isError :: Text -> Bool
    isError :: Text -> Bool
isError t :: Text
t = Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ["", "    1 image files updated"]

-- | Read all metadata from a file, with ExifTool errors leading to runtime
-- errors. (Use 'getMetaEither' instead if you would rather intercept them.)
getMeta :: ExifTool    -- ^ ExifTool instance
        -> Text        -- ^ file name
        -> IO Metadata -- ^ tag/value Map
getMeta :: ExifTool -> Text -> IO Metadata
getMeta et :: ExifTool
et file :: Text
file = Either Text Metadata -> Metadata
forall a. Either Text a -> a
eitherError (Either Text Metadata -> Metadata)
-> IO (Either Text Metadata) -> IO Metadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> Text -> IO (Either Text Metadata)
getMetaEither ExifTool
et Text
file

-- | Read all metadata from a file, with ExifTool errors returned as Left
-- values.
getMetaEither :: ExifTool                  -- ^ ExifTool instance
              -> Text                      -- ^ file name
              -> IO (Either Text Metadata) -- ^ tag/value Map
getMetaEither :: ExifTool -> Text -> IO (Either Text Metadata)
getMetaEither et :: ExifTool
et file :: Text
file = do
    Either Text Text
result <- ExifTool -> [Text] -> IO (Either Text Text)
sendCommand ExifTool
et (Text
file Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
options)
    Either Text Metadata -> IO (Either Text Metadata)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Metadata -> IO (Either Text Metadata))
-> Either Text Metadata -> IO (Either Text Metadata)
forall a b. (a -> b) -> a -> b
$ Either Text Text
result Either Text Text
-> (Text -> Either Text Metadata) -> Either Text Metadata
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Either Text Metadata
parseOutput
  where
    parseOutput :: Text -> Either Text Metadata
    parseOutput :: Text -> Either Text Metadata
parseOutput = (String -> Text)
-> ([Metadata] -> Metadata)
-> Either String [Metadata]
-> Either Text Metadata
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [Metadata] -> Metadata
forall a. [a] -> a
head (Either String [Metadata] -> Either Text Metadata)
-> (Text -> Either String [Metadata])
-> Text
-> Either Text Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String [Metadata]
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String [Metadata])
-> (Text -> ByteString) -> Text -> Either String [Metadata]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
    options :: [Text]
options = ["-json", "-a", "-G:0:1", "-s", "-binary"]

-- | Write metadata to a file, with ExifTool errors leading to runtime errors.
-- (Use 'setMetaEither' instead if you would rather intercept them.) The file is
-- modified in place. Make sure you have the necessary backups!
setMeta :: ExifTool -- ^ ExifTool instance
        -> Metadata -- ^ tag/value Map
        -> Text     -- ^ file name
        -> IO ()
setMeta :: ExifTool -> Metadata -> Text -> IO ()
setMeta et :: ExifTool
et m :: Metadata
m file :: Text
file = Either Text () -> ()
forall a. Either Text a -> a
eitherError (Either Text () -> ()) -> IO (Either Text ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> Metadata -> Text -> IO (Either Text ())
setMetaEither ExifTool
et Metadata
m Text
file

-- | Write metadata to a file, with ExifTool errors returned as Left values. The
-- file is modified in place. Make sure you have the necessary backups!
setMetaEither :: ExifTool            -- ^ ExifTool instance
              -> Metadata            -- ^ tag/value Map
              -> Text                -- ^ file name
              -> IO (Either Text ())
setMetaEither :: ExifTool -> Metadata -> Text -> IO (Either Text ())
setMetaEither et :: ExifTool
et m :: Metadata
m file :: Text
file =
    String
-> (String -> Handle -> IO (Either Text ())) -> IO (Either Text ())
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile "exiftool.json" ((String -> Handle -> IO (Either Text ())) -> IO (Either Text ()))
-> (String -> Handle -> IO (Either Text ())) -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ \metafile :: String
metafile h :: Handle
h -> do
        Handle -> ByteString -> IO ()
hPut Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [Metadata] -> ByteString
forall a. ToJSON a => a -> ByteString
encode [Tag -> Metadata -> Metadata
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
delete (Text -> Text -> Text -> Tag
Tag "" "" "SourceFile") Metadata
m]
        Handle -> IO ()
hFlush Handle
h
        Either Text Text -> Either Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either Text Text -> Either Text ())
-> IO (Either Text Text) -> IO (Either Text ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> [Text] -> IO (Either Text Text)
sendCommand ExifTool
et (Text
file Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: "-json=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
metafile Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
options)
  where
    options :: [Text]
options = ["-overwrite_original", "-f"]

-- | Delete metadata from a file, with ExifTool errors leading to runtime
-- errors. (Use 'deleteMetaEither' instead if you would rather intercept them.)
-- The file is modified in place. Make sure you have the necessary backups!
deleteMeta :: ExifTool -- ^ ExifTool instance
           -> [Tag]    -- ^ tags to be deleted
           -> Text     -- ^ file name
           -> IO ()
deleteMeta :: ExifTool -> [Tag] -> Text -> IO ()
deleteMeta et :: ExifTool
et ts :: [Tag]
ts file :: Text
file = Either Text () -> ()
forall a. Either Text a -> a
eitherError (Either Text () -> ()) -> IO (Either Text ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> [Tag] -> Text -> IO (Either Text ())
deleteMetaEither ExifTool
et [Tag]
ts Text
file

-- | Delete metadata from a file, with ExifTool errors returned as Left values.
-- The file is modified in place. Make sure you have the necessary backups!
deleteMetaEither :: ExifTool            -- ^ ExifTool instance
                 -> [Tag]               -- ^ tags to be deleted
                 -> Text                -- ^ file name
                 -> IO (Either Text ())
deleteMetaEither :: ExifTool -> [Tag] -> Text -> IO (Either Text ())
deleteMetaEither et :: ExifTool
et ts :: [Tag]
ts = ExifTool -> Metadata -> Text -> IO (Either Text ())
setMetaEither ExifTool
et ([(Tag, Value)] -> Metadata
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList ([(Tag, Value)] -> Metadata) -> [(Tag, Value)] -> Metadata
forall a b. (a -> b) -> a -> b
$ (Tag -> (Tag, Value)) -> [Tag] -> [(Tag, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Text -> Value
String "-") [Tag]
ts)

-- | Filter metadata by tag name.
filterByTag :: (Tag -> Bool) -> Metadata -> Metadata
filterByTag :: (Tag -> Bool) -> Metadata -> Metadata
filterByTag p :: Tag -> Bool
p = (Tag -> Value -> Bool) -> Metadata -> Metadata
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
filterWithKey (\t :: Tag
t _ -> Tag -> Bool
p Tag
t)

-- | Filter metadata by fuzzy tag name matching. Tag names are matched ignoring
-- case, and empty components of the given tag name are considered wildcards.
-- Examples:
--
-- * @m ~~ Tag \"EXIF\" \"IFD0\" \"XResolution\"@ matches exactly the given tag
--   name (ignoring case)
-- * @m ~~ Tag "exif" "" "xresolution"@ matches all EXIF tags with name
--   xresolution (ignoring case), including @EXIF:IFD0:XResolution@ and
--   @EXIF:IFD1:XResolution@
-- * @m ~~ Tag \"XMP\" "" ""@ matches all XMP tags
--
-- Note that @~~@ has higher precedence than '<>', so @m ~~ t <> m ~~ t' == (m
-- ~~ t) <> (m ~~ t')@ which makes combining filters easy.
--
-- Hint: This operator is useful to find exact tag names in ghci.
(~~) :: Metadata -> Tag -> Metadata
infixl 8 ~~
~~ :: Metadata -> Tag -> Metadata
(~~) m :: Metadata
m t :: Tag
t = (Tag -> Bool) -> Metadata -> Metadata
filterByTag (Tag -> Tag -> Bool
match Tag
t) Metadata
m
  where
    match :: Tag -> Tag -> Bool
    match :: Tag -> Tag -> Bool
match (Tag f0 :: Text
f0 f1 :: Text
f1 n :: Text
n) (Tag f0' :: Text
f0' f1' :: Text
f1' n' :: Text
n') =
        Text -> Text -> Bool
match' Text
f0 Text
f0' Bool -> Bool -> Bool
&& Text -> Text -> Bool
match' Text
f1 Text
f1' Bool -> Bool -> Bool
&& Text -> Text -> Bool
match' Text
n Text
n'
    match' :: Text -> Text -> Bool
    match' :: Text -> Text -> Bool
match' "" _ = Bool
True -- But not in reverse!
    match' x :: Text
x x' :: Text
x' = Text -> Text
T.toCaseFold Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold Text
x'

-- | Extract content from Right or throw error.
eitherError :: Either Text a -> a
eitherError :: Either Text a -> a
eitherError = (Text -> a) -> (a -> a) -> Either Text a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs) a -> a
forall a. a -> a
id