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

-- |
-- Module     : ExifTool
-- Copyright  : (c) Martin Hoppenheit 2021
-- 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 OverloadedLists #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Data.HashMap.Strict ((!?))
-- > import ExifTool
-- > 
-- > 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 Data.Bifunctor (bimap)
import GHC.Generics (Generic)
import System.IO (Handle, hFlush, hReady)

import Data.Aeson
  ( FromJSON (..),
    FromJSONKey (..),
    FromJSONKeyFunction (..),
    ToJSON (..),
    ToJSONKey (..),
    ToJSONKeyFunction (..),
    eitherDecode,
    encode,
  )
import qualified Data.Aeson as JSON
import Data.Aeson.Encoding.Internal (bool, list, scientific, text)
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 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
      -- STDIN of this ExifTool process
      !Handle
      -- STDOUT of this ExifTool process
      !Handle
      -- STDERR of this ExifTool process
      !Handle
      -- process handle of this ExifTool process
      !ProcessHandle

-- | 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
  { -- | family 0 tag group
    Tag -> Text
tagFamily0 :: !Text,
    -- | family 1 tag group
    Tag -> Text
tagFamily1 :: !Text,
    -- | actual tag name
    Tag -> Text
tagName :: !Text
  }
  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 Text
x)
    | Just Tag
t <- Text -> Maybe Tag
readTag Text
x = Tag -> Parser Tag
forall (m :: * -> *) a. Monad m => a -> m a
return Tag
t
  parseJSON 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
$ String
"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 Text
t =
  case Text -> Text -> [Text]
T.splitOn Text
":" Text
t of
    [Text
f0, Text
f1, 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
    [Text
f0, 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
"" Text
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
"" Text
"" Text
n
    [Text]
_ -> 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 Text
f0 Text
f1 Text
n) = Text -> [Text] -> Text
T.intercalate Text
":" ([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 Text
x)
    | Just Text
b <- Text -> Text -> Maybe Text
T.stripPrefix Text
"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 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 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 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 Value
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 Text
""
  -- parseJSON (JSON.Object x) = Struct <$> sequence (fmap parseJSON x)
  parseJSON 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
$ String
"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 Text
x) = Text -> Value
JSON.String Text
x
  toJSON (Binary ByteString
x) = Text -> Value
JSON.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
"base64:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
encodeBase64 ByteString
x
  toJSON (Number Scientific
x) = Scientific -> Value
JSON.Number Scientific
x
  toJSON (Bool Bool
x) = Bool -> Value
JSON.Bool Bool
x
  toJSON (List [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 Text
x) = Text -> Encoding
forall a. Text -> Encoding' a
text Text
x
  toEncoding (Binary ByteString
x) = Text -> Encoding
forall a. Text -> Encoding' a
text (Text -> Encoding) -> Text -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"base64:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
encodeBase64 ByteString
x
  toEncoding (Number Scientific
x) = Scientific -> Encoding
scientific Scientific
x
  toEncoding (Bool Bool
x) = Bool -> Encoding
bool Bool
x
  toEncoding (List [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 Handle
i, Just Handle
o, Just Handle
e, 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 String
"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 = [String
"-stay_open", String
"True", String
"-@", String
"-"]

-- | Stop a running ExifTool instance.
stopExifTool :: ExifTool -> IO ()
stopExifTool :: ExifTool -> IO ()
stopExifTool (ET Handle
i Handle
o Handle
e ProcessHandle
p) = do
  Handle -> Text -> IO ()
hPutStrLn Handle
i Text
"-stay_open"
  Handle -> Text -> IO ()
hPutStrLn Handle
i Text
"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 Handle
i Handle
o Handle
e ProcessHandle
_) [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 Text
"-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
""
  Text
err <- Handle -> Text -> IO Text
readErr Handle
e Text
""
  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
    readOut :: Handle -> Text -> IO Text
    readOut :: Handle -> Text -> IO Text
readOut Handle
h Text
acc = do
      Text
l <- Handle -> IO Text
hGetLine Handle
h
      if Text
"{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)
    readErr :: Handle -> Text -> IO Text
    readErr :: Handle -> Text -> IO Text
readErr Handle
h 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)
    isError :: Text -> Bool
    isError :: Text -> Bool
isError Text
t = Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"", Text
"    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 instance
  ExifTool ->
  -- | file name
  Text ->
  -- | tag/value Map
  IO Metadata
getMeta :: ExifTool -> Text -> IO Metadata
getMeta ExifTool
et 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 instance
  ExifTool ->
  -- | file name
  Text ->
  -- | tag/value Map
  IO (Either Text Metadata)
getMetaEither :: ExifTool -> Text -> IO (Either Text Metadata)
getMetaEither ExifTool
et 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 = [Text
"-json", Text
"-a", Text
"-U", Text
"-G:0:1", Text
"-s", Text
"-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 instance
  ExifTool ->
  -- | tag/value Map
  Metadata ->
  -- | file name
  Text ->
  IO ()
setMeta :: ExifTool -> Metadata -> Text -> IO ()
setMeta ExifTool
et Metadata
m 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 instance
  ExifTool ->
  -- | tag/value Map
  Metadata ->
  -- | file name
  Text ->
  IO (Either Text ())
setMetaEither :: ExifTool -> Metadata -> Text -> IO (Either Text ())
setMetaEither ExifTool
et Metadata
m 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 String
"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
$ \String
metafile 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 Text
"" Text
"" Text
"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]
: Text
"-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 = [Text
"-overwrite_original", Text
"-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 instance
  ExifTool ->
  -- | tags to be deleted
  [Tag] ->
  -- | file name
  Text ->
  IO ()
deleteMeta :: ExifTool -> [Tag] -> Text -> IO ()
deleteMeta ExifTool
et [Tag]
ts 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 instance
  ExifTool ->
  -- | tags to be deleted
  [Tag] ->
  -- | file name
  Text ->
  IO (Either Text ())
deleteMetaEither :: ExifTool -> [Tag] -> Text -> IO (Either Text ())
deleteMetaEither ExifTool
et [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 Text
"-") [Tag]
ts)

-- | Filter metadata by tag name.
filterByTag :: (Tag -> Bool) -> Metadata -> Metadata
filterByTag :: (Tag -> Bool) -> Metadata -> Metadata
filterByTag Tag -> Bool
p = (Tag -> Value -> Bool) -> Metadata -> Metadata
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
filterWithKey (\Tag
t Value
_ -> 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.
infixl 8 ~~
(~~) :: Metadata -> Tag -> Metadata
~~ :: Metadata -> Tag -> Metadata
(~~) Metadata
m 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 Text
f0 Text
f1 Text
n) (Tag Text
f0' Text
f1' 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' Text
"" Text
_ = Bool
True -- But not in reverse!
    match' Text
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