{-# 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')
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 -> String
(Int -> Metadata -> ShowS)
-> (Metadata -> String) -> ([Metadata] -> ShowS) -> Show Metadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metadata] -> ShowS
$cshowList :: [Metadata] -> ShowS
show :: Metadata -> String
$cshow :: Metadata -> String
showsPrec :: Int -> Metadata -> ShowS
$cshowsPrec :: Int -> Metadata -> ShowS
Show, Metadata -> Metadata -> Bool
(Metadata -> Metadata -> Bool)
-> (Metadata -> Metadata -> Bool) -> Eq Metadata
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 (b -> Metadata -> Metadata
NonEmpty Metadata -> Metadata
Metadata -> Metadata -> Metadata
(Metadata -> Metadata -> Metadata)
-> (NonEmpty Metadata -> Metadata)
-> (forall b. Integral b => b -> Metadata -> Metadata)
-> Semigroup 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 :: 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
Semigroup Metadata
-> Metadata
-> (Metadata -> Metadata -> Metadata)
-> ([Metadata] -> Metadata)
-> Monoid 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
$cp1Monoid :: Semigroup 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 -> 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)
  deriving (Eq Tag
Eq Tag -> (Int -> Tag -> Int) -> (Tag -> Int) -> Hashable 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
$cp1Hashable :: Eq Tag
Hashable, Value -> Parser [Tag]
Value -> Parser Tag
(Value -> Parser Tag) -> (Value -> Parser [Tag]) -> FromJSON 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
FromJSONKeyFunction Tag
-> FromJSONKeyFunction [Tag] -> FromJSONKey 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
(Tag -> Value)
-> (Tag -> Encoding)
-> ([Tag] -> Value)
-> ([Tag] -> Encoding)
-> ToJSON Tag
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
ToJSONKeyFunction Tag -> ToJSONKeyFunction [Tag] -> ToJSONKey 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 (Text -> Tag) -> (Tag -> Text) -> Tag -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
last ([Text] -> Text) -> (Tag -> [Text]) -> Tag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn Text
":" (Text -> [Text]) -> (Tag -> Text) -> Tag -> [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 (Text -> Tag) -> (Tag -> Text) -> Tag -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toCaseFold (Text -> Text) -> (Tag -> Text) -> Tag -> Text
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 -> 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
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
. forall source. From source String => source -> String
forall target source. From source target => source -> target
into @String)
          (Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 target source. From source target => source -> target
into @ByteString Text
b)
    | Bool
otherwise = Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure (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)
-> (Vector Value -> [Value]) -> Vector Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Value -> [Value]
forall a. Vector a -> [a]
Vector.toList (Vector Value -> Value) -> Parser (Vector Value) -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser Value) -> Array -> Parser (Vector Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser Value
forall a. FromJSON a => Value -> Parser a
parseJSON Array
xs
  parseJSON Value
JSON.Null = Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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

-- | 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 = Value -> Maybe Value
forall a. a -> Maybe a
Just

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

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

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

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

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

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

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

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

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

instance FromValue Bool where
  fromValue :: Value -> Maybe Bool
fromValue (Bool Bool
x) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
  fromValue Value
_ = Maybe Bool
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) = (Value -> Maybe a) -> [Value] -> Maybe [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromValue [Value]
xs
  fromValue Value
_ = Maybe [a]
forall a. Maybe a
Nothing

instance ToValue a => ToValue [a] where
  toValue :: [a] -> Value
toValue = [Value] -> Value
List ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
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
  ExifTool -> IO ExifTool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure (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
`isPrefixOf` Text
l
        then Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (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 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 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] -> String -> IO Metadata
readMeta ExifTool
et [Tag]
ts String
fp = 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 -> [Tag] -> String -> IO (Either Text Metadata)
readMetaEither ExifTool
et [Tag]
ts String
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] -> String -> IO (Either Text Metadata)
readMetaEither ExifTool
et [Tag]
ts String
fp = do
  Either Text Text
result <- ExifTool -> [Text] -> IO (Either Text Text)
sendCommand ExifTool
et (String -> Text
forall target source. From source target => source -> target
into @Text String
fp Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
options [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
tags)
  Either Text Metadata -> IO (Either Text Metadata)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Metadata -> IO (Either Text Metadata))
-> Either Text Metadata -> IO (Either Text Metadata)
forall a b. (a -> b) -> a -> b
$ HashMap Tag Value -> Metadata
Metadata (HashMap Tag Value -> Metadata)
-> (HashMap Tag Value -> HashMap Tag Value)
-> HashMap Tag Value
-> Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag -> Tag) -> HashMap Tag Value -> HashMap Tag Value
forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
mapKeys Tag -> Tag
toLower (HashMap Tag Value -> Metadata)
-> Either Text (HashMap Tag Value) -> Either Text Metadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either Text Text
result Either Text Text
-> (Text -> Either Text (HashMap Tag Value))
-> Either Text (HashMap Tag Value)
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 = (Tag -> Text) -> [Tag] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Tag -> Text) -> Tag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
tagName) [Tag]
ts
    parseOutput :: Text -> Either Text (HashMap Tag Value)
parseOutput = (String -> Text)
-> ([HashMap Tag Value] -> HashMap Tag Value)
-> Either String [HashMap Tag Value]
-> Either Text (HashMap Tag Value)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall source. From source Text => source -> Text
forall target source. From source target => source -> target
into @Text) [HashMap Tag Value] -> HashMap Tag Value
forall a. [a] -> a
head (Either String [HashMap Tag Value]
 -> Either Text (HashMap Tag Value))
-> (Text -> Either String [HashMap Tag Value])
-> Text
-> Either Text (HashMap Tag Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String [HashMap Tag Value]
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String [HashMap Tag Value])
-> (Text -> ByteString)
-> Text
-> Either String [HashMap Tag Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source. From source ByteString => source -> ByteString
forall target source. From source target => source -> target
into @BL.ByteString

-- | 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 -> String -> IO ()
writeMeta ExifTool
et Metadata
m String
fp = 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 -> String -> IO (Either Text ())
writeMetaEither ExifTool
et Metadata
m String
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 -> String -> IO (Either Text ())
writeMetaEither ExifTool
et (Metadata HashMap Tag Value
m) String
fp =
  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 ()
BL.hPut Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [HashMap Tag Value] -> ByteString
forall a. ToJSON a => a -> ByteString
encode [Tag -> HashMap Tag Value -> HashMap Tag Value
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
    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
        (String -> Text
forall target source. From source target => source -> target
into @Text String
fp Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"-json=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall target source. From source target => source -> target
into @Text String
metafile Text -> [Text] -> [Text]
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 :: Tag -> Metadata -> Maybe a
get Tag
t (Metadata HashMap Tag Value
m) = do
  Value
v <- HashMap Tag Value
m HashMap Tag Value -> Tag -> Maybe Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Tag -> Tag
toLower Tag
t
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Value
String Text
"-") -- Marked for deletion, see del function below.
  Value -> Maybe a
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 :: Tag -> a -> Metadata -> Metadata
set Tag
t a
v (Metadata HashMap Tag Value
m) = HashMap Tag Value -> Metadata
Metadata (HashMap Tag Value -> Metadata) -> HashMap Tag Value -> Metadata
forall a b. (a -> b) -> a -> b
$ Tag -> Value -> HashMap Tag Value -> HashMap Tag Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert (Tag -> Tag
toLower Tag
t) (a -> Value
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 = Tag -> Value -> Metadata -> Metadata
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 :: 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
. forall source. From source String => source -> String
forall target source. From source target => source -> target
into @String) a -> a
forall a. a -> a
id