{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module     : ExifTool
-- Copyright  : (c) Martin Hoppenheit 2020-2022
-- 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 #-}
-- >
-- > import Data.Text (Text)
-- > import ExifTool
-- >
-- > data Foo = Foo
-- >   { description :: Text,
-- >     resolution :: Int
-- >   }
-- >   deriving (Show)
-- >
-- > main :: IO ()
-- > main = withExifTool $ \et -> do
-- >   m <- readMeta et [] "a.jpg"
-- >   print $ Foo <$> get (Tag "Description") m <*> get (Tag "XResolution") m
-- >   let m' = del (Tag "Description") . set (Tag "XResolution") (42 :: Int) $ m
-- >   writeMeta et m' "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 or write metadata in a
    -- file with the respective functions.
    readMeta,
    readMetaEither,
    writeMeta,
    writeMetaEither,
    -- | Metadata is represented by a set of 'Tag'/'Value' pairs that can be
    -- queried and manipulated with the respective functions.
    Metadata,
    Tag (..),
    stripGroups,
    Value (..),
    FromValue (..),
    ToValue (..),
    get,
    set,
    del,
  )
where

import Control.Exception (bracket)
import Control.Monad (guard, void)
import Data.Aeson
  ( FromJSON (..),
    FromJSONKey (..),
    ToJSON (..),
    ToJSONKey (..),
    eitherDecode,
    encode,
  )
import qualified Data.Aeson as JSON
import Data.Aeson.Encoding.Internal (bool, list, scientific, text)
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (decodeBase64, encodeBase64)
import qualified Data.ByteString.Lazy as BL
import Data.HashMap.Strict (HashMap, delete, insert, mapKeys, (!?))
import Data.Hashable (Hashable)
import Data.Scientific
  ( FPFormat (Fixed),
    Scientific,
    formatScientific,
    fromFloatDigits,
    isInteger,
    toBoundedInteger,
    toRealFloat,
  )
import Data.Text
  ( Text,
    intercalate,
    isPrefixOf,
    splitOn,
    stripPrefix,
    toCaseFold,
  )
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Text.IO (hGetLine, hPutStrLn)
import qualified Data.Vector as Vector
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,
  )
import Witch (into)

-- | 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. Use 'get', 'set' and 'del' to query and
-- manipulate this set.
newtype Metadata = Metadata (HashMap Tag Value)
  deriving (Int -> Metadata -> ShowS
[Metadata] -> ShowS
Metadata -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Metadata] -> ShowS
$cshowList :: [Metadata] -> ShowS
show :: Metadata -> FilePath
$cshow :: Metadata -> FilePath
showsPrec :: Int -> Metadata -> ShowS
$cshowsPrec :: Int -> Metadata -> ShowS
Show, Metadata -> Metadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metadata -> Metadata -> Bool
$c/= :: Metadata -> Metadata -> Bool
== :: Metadata -> Metadata -> Bool
$c== :: Metadata -> Metadata -> Bool
Eq)
  deriving (NonEmpty Metadata -> Metadata
Metadata -> Metadata -> Metadata
forall b. Integral b => b -> Metadata -> Metadata
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Metadata -> Metadata
$cstimes :: forall b. Integral b => b -> Metadata -> Metadata
sconcat :: NonEmpty Metadata -> Metadata
$csconcat :: NonEmpty Metadata -> Metadata
<> :: Metadata -> Metadata -> Metadata
$c<> :: Metadata -> Metadata -> Metadata
Semigroup, Semigroup Metadata
Metadata
[Metadata] -> Metadata
Metadata -> Metadata -> Metadata
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Metadata] -> Metadata
$cmconcat :: [Metadata] -> Metadata
mappend :: Metadata -> Metadata -> Metadata
$cmappend :: Metadata -> Metadata -> Metadata
mempty :: Metadata
$cmempty :: Metadata
Monoid) via (HashMap Tag Value)

-- | An ExifTool tag name like @Tag "Description"@ or @Tag
-- "EXIF:IFD0:XResolution"@.
newtype Tag = Tag {Tag -> Text
tagName :: Text}
  deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> FilePath
$cshow :: Tag -> FilePath
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, Tag -> Tag -> Bool
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)
  deriving (Eq Tag
Int -> Tag -> Int
Tag -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Tag -> Int
$chash :: Tag -> Int
hashWithSalt :: Int -> Tag -> Int
$chashWithSalt :: Int -> Tag -> Int
Hashable, Value -> Parser [Tag]
Value -> Parser Tag
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Tag]
$cparseJSONList :: Value -> Parser [Tag]
parseJSON :: Value -> Parser Tag
$cparseJSON :: Value -> Parser Tag
FromJSON, FromJSONKeyFunction [Tag]
FromJSONKeyFunction Tag
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [Tag]
$cfromJSONKeyList :: FromJSONKeyFunction [Tag]
fromJSONKey :: FromJSONKeyFunction Tag
$cfromJSONKey :: FromJSONKeyFunction Tag
FromJSONKey, [Tag] -> Encoding
[Tag] -> Value
Tag -> Encoding
Tag -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Tag] -> Encoding
$ctoEncodingList :: [Tag] -> Encoding
toJSONList :: [Tag] -> Value
$ctoJSONList :: [Tag] -> Value
toEncoding :: Tag -> Encoding
$ctoEncoding :: Tag -> Encoding
toJSON :: Tag -> Value
$ctoJSON :: Tag -> Value
ToJSON, ToJSONKeyFunction [Tag]
ToJSONKeyFunction Tag
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [Tag]
$ctoJSONKeyList :: ToJSONKeyFunction [Tag]
toJSONKey :: ToJSONKeyFunction Tag
$ctoJSONKey :: ToJSONKeyFunction Tag
ToJSONKey) via Text

-- | Remove group prefixes from a tag name e.g., @stripGroups (Tag
-- "XMP:XMP-dc:Description") == Tag "Description"@.
stripGroups :: Tag -> Tag
stripGroups :: Tag -> Tag
stripGroups = Text -> Tag
Tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn Text
":" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
tagName

-- | Make a tag name lower case.
toLower :: Tag -> Tag
toLower :: Tag -> Tag
toLower = Text -> Tag
Tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toCaseFold forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
tagName

-- | An ExifTool tag value, enclosed in a type wrapper. The type wrapper can
-- usually be ignored when using the 'FromValue' and 'ToValue' instances.
data Value
  = String !Text
  | Binary !ByteString
  | Number !Scientific
  | Bool !Bool
  | List ![Value]
  -- Struct (Map Text Value)
  deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> FilePath
$cshow :: Value -> FilePath
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Value -> Value -> Bool
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
stripPrefix Text
"base64:" Text
x =
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @String)
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Value
Binary)
          (ByteString -> Either Text ByteString
decodeBase64 forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
b)
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
x
  parseJSON (JSON.Number Scientific
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number Scientific
x
  parseJSON (JSON.Bool Bool
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Value
Bool Bool
x
  parseJSON (JSON.Array Array
xs) = [Value] -> Value
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
Vector.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. FromJSON a => Value -> Parser a
parseJSON Array
xs
  parseJSON Value
JSON.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
""
  -- parseJSON (JSON.Object x) = Struct <$> sequence (fmap parseJSON x)
  parseJSON Value
x = forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"error parsing ExifTool JSON output: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
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 forall a b. (a -> b) -> a -> b
$ Text
"base64:" 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
toJSON [Value]
xs
  toEncoding :: Value -> Encoding
toEncoding (String Text
x) = forall a. Text -> Encoding' a
text Text
x
  toEncoding (Binary ByteString
x) = forall a. Text -> Encoding' a
text forall a b. (a -> b) -> a -> b
$ Text
"base64:" 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) = forall a. (a -> Encoding) -> [a] -> Encoding
list forall a. ToJSON a => a -> Encoding
toEncoding [Value]
xs

-- | Data types that a 'Value' can be turned into.
--
-- @since 0.2.0.0
class FromValue a where
  fromValue :: Value -> Maybe a

-- | Data types that can be turned into a 'Value'.
--
-- @since 0.2.0.0
class ToValue a where
  toValue :: a -> Value

instance FromValue Value where
  fromValue :: Value -> Maybe Value
fromValue = forall a. a -> Maybe a
Just

instance ToValue Value where
  toValue :: Value -> Value
toValue = forall a. a -> a
id

instance FromValue Text where
  fromValue :: Value -> Maybe Text
fromValue (String Text
x) = forall a. a -> Maybe a
Just Text
x
  fromValue (Binary ByteString
x) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
x
  fromValue (Number Scientific
x) =
    forall a. a -> Maybe a
Just
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @Text
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. FPFormat -> Maybe Int -> Scientific -> FilePath
formatScientific FPFormat
Fixed (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if Scientific -> Bool
isInteger Scientific
x then Int
0 else Int
2)
      forall a b. (a -> b) -> a -> b
$ Scientific
x
  fromValue (Bool Bool
x) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @Text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ Bool
x
  fromValue (List [Value]
xs) = Text -> [Text] -> Text
intercalate Text
", " forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. FromValue a => Value -> Maybe a
fromValue [Value]
xs

instance ToValue Text where
  toValue :: Text -> Value
toValue = Text -> Value
String

instance FromValue ByteString where
  fromValue :: Value -> Maybe ByteString
fromValue (Binary ByteString
x) = forall a. a -> Maybe a
Just ByteString
x
  fromValue Value
_ = forall a. Maybe a
Nothing

instance ToValue ByteString where
  toValue :: ByteString -> Value
toValue = ByteString -> Value
Binary

instance FromValue Int where
  fromValue :: Value -> Maybe Int
fromValue (Number Scientific
x) = forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
x
  fromValue Value
_ = forall a. Maybe a
Nothing

instance ToValue Int where
  toValue :: Int -> Value
toValue = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromValue Integer where
  fromValue :: Value -> Maybe Integer
fromValue Value
x = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. FromValue a => Value -> Maybe a
fromValue Value
x :: Maybe Int)

instance ToValue Integer where
  toValue :: Integer -> Value
toValue = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromValue Float where
  fromValue :: Value -> Maybe Float
fromValue (Number Scientific
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
x
  fromValue Value
_ = forall a. Maybe a
Nothing

instance ToValue Float where
  toValue :: Float -> Value
toValue = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> Scientific
fromFloatDigits

instance FromValue Double where
  fromValue :: Value -> Maybe Double
fromValue (Number Scientific
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
x
  fromValue Value
_ = forall a. Maybe a
Nothing

instance ToValue Double where
  toValue :: Double -> Value
toValue = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> Scientific
fromFloatDigits

instance FromValue Bool where
  fromValue :: Value -> Maybe Bool
fromValue (Bool Bool
x) = forall a. a -> Maybe a
Just Bool
x
  fromValue Value
_ = forall a. Maybe a
Nothing

instance ToValue Bool where
  toValue :: Bool -> Value
toValue = Bool -> Value
Bool

instance FromValue a => FromValue [a] where
  fromValue :: Value -> Maybe [a]
fromValue (List [Value]
xs) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. FromValue a => Value -> Maybe a
fromValue [Value]
xs
  fromValue Value
_ = forall a. Maybe a
Nothing

instance ToValue a => ToValue [a] where
  toValue :: [a] -> Value
toValue = [Value] -> Value
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToValue a => a -> Value
toValue

-- | 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 =
      (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"exiftool" [FilePath]
options)
        { std_in :: StdStream
std_in = StdStream
CreatePipe,
          std_out :: StdStream
std_out = StdStream
CreatePipe,
          std_err :: StdStream
std_err = StdStream
CreatePipe
        }
    options :: [FilePath]
options = [FilePath
"-stay_open", FilePath
"True", FilePath
"-@", FilePath
"-"]

-- | 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 (forall a. a -> Maybe a
Just Handle
i, forall a. a -> Maybe a
Just Handle
o, 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 :: forall a. (ExifTool -> IO a) -> IO a
withExifTool = 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
  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
""
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    if Text -> Bool
isError Text
err
      then forall a b. a -> Either a b
Left Text
err
      else 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
`isPrefixOf` Text
l
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
acc
        else Handle -> Text -> IO Text
readOut Handle
h (Text
acc 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
acc
        else do
          Text
l <- Handle -> IO Text
hGetLine Handle
h
          Handle -> Text -> IO Text
readErr Handle
h (Text
acc forall a. Semigroup a => a -> a -> a
<> Text
l)
    isError :: Text -> Bool
    isError :: Text -> Bool
isError Text
t = Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"", Text
"    1 image files updated"]

-- | Read the given tags from a file. Use an empty tag list to return all
-- metadata. Tag names are returned in "simple" form without any leading group
-- prefixes, independent of how they are specified in the given tag list.
--
-- @since 0.2.0.0
readMeta :: ExifTool -> [Tag] -> FilePath -> IO Metadata
readMeta :: ExifTool -> [Tag] -> FilePath -> IO Metadata
readMeta ExifTool
et [Tag]
ts FilePath
fp = forall a. Either Text a -> a
eitherError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> [Tag] -> FilePath -> IO (Either Text Metadata)
readMetaEither ExifTool
et [Tag]
ts FilePath
fp

-- | Like 'readMeta', but ExifTool errors are returned as Left values instead of
-- leading to runtime errors.
--
-- @since 0.2.0.0
readMetaEither :: ExifTool -> [Tag] -> FilePath -> IO (Either Text Metadata)
readMetaEither :: ExifTool -> [Tag] -> FilePath -> IO (Either Text Metadata)
readMetaEither ExifTool
et [Tag]
ts FilePath
fp = do
  Either Text Text
result <- ExifTool -> [Text] -> IO (Either Text Text)
sendCommand ExifTool
et (forall target source. From source target => source -> target
into @Text FilePath
fp forall a. a -> [a] -> [a]
: [Text]
options forall a. Semigroup a => a -> a -> a
<> [Text]
tags)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HashMap Tag Value -> Metadata
Metadata forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
mapKeys Tag -> Tag
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either Text Text
result forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Either Text (HashMap Tag Value)
parseOutput)
  where
    options :: [Text]
options = [Text
"-json", Text
"-binary", Text
"-unknown2"]
    tags :: [Text]
tags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
"-" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
tagName) [Tag]
ts
    parseOutput :: Text -> Either Text (HashMap Tag Value)
parseOutput =
      forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall target source. From source target => source -> target
into @Text) forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @BL.ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Write metadata to a file. The file is modified in place, make sure you have
-- the necessary backups!
--
-- @since 0.2.0.0
writeMeta :: ExifTool -> Metadata -> FilePath -> IO ()
writeMeta :: ExifTool -> Metadata -> FilePath -> IO ()
writeMeta ExifTool
et Metadata
m FilePath
fp = forall a. Either Text a -> a
eitherError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> Metadata -> FilePath -> IO (Either Text ())
writeMetaEither ExifTool
et Metadata
m FilePath
fp

-- | Like 'writeMeta', but ExifTool errors are returned as Left values instead
-- of leading to runtime errors.
--
-- @since 0.2.0.0
writeMetaEither :: ExifTool -> Metadata -> FilePath -> IO (Either Text ())
writeMetaEither :: ExifTool -> Metadata -> FilePath -> IO (Either Text ())
writeMetaEither ExifTool
et (Metadata HashMap Tag Value
m) FilePath
fp =
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"exiftool.json" forall a b. (a -> b) -> a -> b
$ \FilePath
metafile Handle
h -> do
    Handle -> ByteString -> IO ()
BL.hPut Handle
h forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode [forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
delete (Text -> Tag
Tag Text
"SourceFile") HashMap Tag Value
m]
    Handle -> IO ()
hFlush Handle
h
    forall (f :: * -> *) a. Functor f => f a -> f ()
void
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExifTool -> [Text] -> IO (Either Text Text)
sendCommand
        ExifTool
et
        (forall target source. From source target => source -> target
into @Text FilePath
fp forall a. a -> [a] -> [a]
: Text
"-json=" forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text FilePath
metafile forall a. a -> [a] -> [a]
: [Text]
options)
  where
    options :: [Text]
options = [Text
"-overwrite_original", Text
"-f"]

-- | Retrieve the value of a tag. Tag case is ignored i.e., @get (Tag
-- "Description)" m == get (Tag "description") m@.
--
-- @since 0.2.0.0
get :: FromValue a => Tag -> Metadata -> Maybe a
get :: forall a. FromValue a => Tag -> Metadata -> Maybe a
get Tag
t (Metadata HashMap Tag Value
m) = do
  Value
v <- HashMap Tag Value
m forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Tag -> Tag
toLower Tag
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value
v forall a. Eq a => a -> a -> Bool
/= Text -> Value
String Text
"-") -- Marked for deletion, see del function below.
  forall a. FromValue a => Value -> Maybe a
fromValue Value
v

-- | Set a tag to a (new) value. Tag case is ignored.
--
-- @since 0.2.0.0
set :: ToValue a => Tag -> a -> Metadata -> Metadata
set :: forall a. ToValue a => Tag -> a -> Metadata -> Metadata
set Tag
t a
v (Metadata HashMap Tag Value
m) = HashMap Tag Value -> Metadata
Metadata forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert (Tag -> Tag
toLower Tag
t) (forall a. ToValue a => a -> Value
toValue a
v) HashMap Tag Value
m

-- | Delete a tag (i.e., set its value to a marker that will make ExifTool
-- delete it when 'writeMeta' is called). Tag case is ignored.
--
-- @since 0.2.0.0
del :: Tag -> Metadata -> Metadata
del :: Tag -> Metadata -> Metadata
del Tag
t = forall a. ToValue a => Tag -> a -> Metadata -> Metadata
set Tag
t (Text -> Value
String Text
"-")

-- | Extract content from Right or throw error.
eitherError :: Either Text a -> a
eitherError :: forall a. Either Text a -> a
eitherError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => FilePath -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @String) forall a. a -> a
id