diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for exiftool +## 0.2.0.1 -- 2022-08-18 + +* Dependency version bumps. + ## 0.2.0.0 -- 2021-09-28 * New (backwards-incompatible) API. Highlights: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2020-2021 Martin Hoppenheit +Copyright (c) 2020-2022 Martin Hoppenheit Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/exiftool.cabal b/exiftool.cabal --- a/exiftool.cabal +++ b/exiftool.cabal @@ -1,38 +1,36 @@ -name: exiftool -version: 0.2.0.0 -synopsis: Haskell bindings to ExifTool -description: Haskell bindings to the [ExifTool](https://exiftool.org) - command-line application that enable reading, writing and - deleting metadata in various file formats. -homepage: https://github.com/marhop/exiftool-haskell -license: MIT -license-file: LICENSE -author: Martin Hoppenheit -maintainer: martin@hoppenheit.info -copyright: 2020-2021 Martin Hoppenheit -category: Foreign -build-type: Simple -extra-source-files: README.md - , CHANGELOG.md -cabal-version: >=1.10 +cabal-version: 3.0 +name: exiftool +version: 0.2.0.1 +synopsis: Haskell bindings to ExifTool +description: Haskell bindings to the [ExifTool](https://exiftool.org) + command-line application that enable reading, writing and + deleting metadata in various file formats. +homepage: https://github.com/marhop/exiftool-haskell +license: MIT +license-file: LICENSE +author: Martin Hoppenheit +maintainer: martin@hoppenheit.info +copyright: 2020-2022 Martin Hoppenheit +category: Foreign +extra-source-files: README.md CHANGELOG.md library - hs-source-dirs: src - exposed-modules: ExifTool - default-language: Haskell2010 - ghc-options: -Wall - build-depends: base >= 4.12 && < 5 - , aeson >= 1.5.4 && < 1.6 - , base64 >= 0.4.2 && < 0.5 - , bytestring >= 0.10.8 && < 0.12 - , hashable >= 1.3.0 && < 1.4 - , process >= 1.6.5 && < 1.7 - , scientific >= 0.3.6 && < 0.4 - , string-conversions >= 0.4.0 && < 0.5 - , temporary >= 1.3 && < 1.4 - , text >= 1.2.3 && < 1.3 - , unordered-containers >= 0.2.12 && < 0.3 - , vector >= 0.12.1 && < 0.13 + hs-source-dirs: lib + exposed-modules: ExifTool + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >= 4.12 && < 5, + aeson >= 1.5.4 && < 2.2, + base64 >= 0.4.2 && < 0.5, + bytestring >= 0.10.8 && < 0.12, + hashable >= 1.3.0 && < 1.5, + process >= 1.6.5 && < 1.7, + scientific >= 0.3.6 && < 0.4, + temporary >= 1.3 && < 1.4, + text >= 1.2.3 && < 2.1, + unordered-containers >= 0.2.12 && < 0.3, + vector >= 0.12.1 && < 0.14, + witch >= 1.0.0 && < 1.1 source-repository head type: git diff --git a/lib/ExifTool.hs b/lib/ExifTool.hs new file mode 100644 --- /dev/null +++ b/lib/ExifTool.hs @@ -0,0 +1,407 @@ +{-# 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 (Show, Eq) + deriving (Semigroup, Monoid) via (HashMap Tag Value) + +-- | An ExifTool tag name like @Tag "Description"@ or @Tag +-- "EXIF:IFD0:XResolution"@. +newtype Tag = Tag {tagName :: Text} + deriving (Show, Eq) + deriving (Hashable, FromJSON, FromJSONKey, ToJSON, 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 . last . splitOn ":" . tagName + +-- | Make a tag name lower case. +toLower :: Tag -> Tag +toLower = Tag . toCaseFold . 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 (Show, Eq) + +instance FromJSON Value where + parseJSON (JSON.String x) + | Just b <- stripPrefix "base64:" x = + either + (fail . into @String) + (pure . Binary) + (decodeBase64 $ into @ByteString b) + | otherwise = pure $ String x + parseJSON (JSON.Number x) = pure $ Number x + parseJSON (JSON.Bool x) = pure $ Bool x + parseJSON (JSON.Array xs) = List . Vector.toList <$> traverse parseJSON xs + parseJSON JSON.Null = pure $ String "" + -- parseJSON (JSON.Object x) = Struct <$> sequence (fmap parseJSON x) + parseJSON x = fail $ "error parsing ExifTool JSON output: " <> show x + +instance ToJSON Value where + toJSON (String x) = JSON.String x + toJSON (Binary x) = JSON.String $ "base64:" <> encodeBase64 x + toJSON (Number x) = JSON.Number x + toJSON (Bool x) = JSON.Bool x + toJSON (List xs) = JSON.Array . Vector.fromList $ map toJSON xs + toEncoding (String x) = text x + toEncoding (Binary x) = text $ "base64:" <> encodeBase64 x + toEncoding (Number x) = scientific x + toEncoding (Bool x) = bool x + toEncoding (List xs) = list toEncoding 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 = Just + +instance ToValue Value where + toValue = id + +instance FromValue Text where + fromValue (String x) = Just x + fromValue (Binary x) = either (const Nothing) Just $ decodeUtf8' x + fromValue (Number x) = + Just + . into @Text + . formatScientific Fixed (Just $ if isInteger x then 0 else 2) + $ x + fromValue (Bool x) = Just . into @Text . show $ x + fromValue (List xs) = intercalate ", " <$> traverse fromValue xs + +instance ToValue Text where + toValue = String + +instance FromValue ByteString where + fromValue (Binary x) = Just x + fromValue _ = Nothing + +instance ToValue ByteString where + toValue = Binary + +instance FromValue Int where + fromValue (Number x) = toBoundedInteger x + fromValue _ = Nothing + +instance ToValue Int where + toValue = Number . fromIntegral + +instance FromValue Integer where + fromValue x = fromIntegral <$> (fromValue x :: Maybe Int) + +instance ToValue Integer where + toValue = Number . fromIntegral + +instance FromValue Float where + fromValue (Number x) = Just $ toRealFloat x + fromValue _ = Nothing + +instance ToValue Float where + toValue = Number . fromFloatDigits + +instance FromValue Double where + fromValue (Number x) = Just $ toRealFloat x + fromValue _ = Nothing + +instance ToValue Double where + toValue = Number . fromFloatDigits + +instance FromValue Bool where + fromValue (Bool x) = Just x + fromValue _ = Nothing + +instance ToValue Bool where + toValue = Bool + +instance FromValue a => FromValue [a] where + fromValue (List xs) = traverse fromValue xs + fromValue _ = Nothing + +instance ToValue a => ToValue [a] where + toValue = List . fmap toValue + +-- | Start an ExifTool instance. Use 'stopExifTool' when done, or 'withExifTool' +-- to combine both steps. +startExifTool :: IO ExifTool +startExifTool = do + (Just i, Just o, Just e, p) <- createProcess conf + pure $ ET i o e p + where + conf = + (proc "exiftool" options) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + options = ["-stay_open", "True", "-@", "-"] + +-- | Stop a running ExifTool instance. +stopExifTool :: ExifTool -> IO () +stopExifTool (ET i o e p) = do + hPutStrLn i "-stay_open" + hPutStrLn i "False" + hFlush i + cleanupProcess (Just i, Just o, Just e, p) + +-- | Start an ExifTool instance, do something with it, then stop it. +withExifTool :: (ExifTool -> IO a) -> IO a +withExifTool = bracket startExifTool 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 (ET i o e _) cmds = do + mapM_ (hPutStrLn i) cmds + hPutStrLn i "-execute" + hFlush i + -- Do not switch the order of readOut/readErr lest we miss errors! + out <- readOut o "" + err <- readErr e "" + pure $ + if isError err + then Left err + else Right out + where + readOut :: Handle -> Text -> IO Text + readOut h acc = do + l <- hGetLine h + if "{ready}" `isPrefixOf` l + then pure acc + else readOut h (acc <> l) + readErr :: Handle -> Text -> IO Text + readErr h acc = do + hasMore <- hReady h + if not hasMore + then pure acc + else do + l <- hGetLine h + readErr h (acc <> l) + isError :: Text -> Bool + isError t = t `notElem` ["", " 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 et ts fp = eitherError <$> readMetaEither et ts 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 et ts fp = do + result <- sendCommand et (into @Text fp : options <> tags) + pure $ Metadata . mapKeys toLower <$> (result >>= parseOutput) + where + options = ["-json", "-binary", "-unknown2"] + tags = fmap (("-" <>) . tagName) ts + parseOutput = bimap (into @Text) head . eitherDecode . 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 et m fp = eitherError <$> writeMetaEither et m 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 et (Metadata m) fp = + withSystemTempFile "exiftool.json" $ \metafile h -> do + BL.hPut h $ encode [delete (Tag "SourceFile") m] + hFlush h + void + <$> sendCommand + et + (into @Text fp : "-json=" <> into @Text metafile : options) + where + options = ["-overwrite_original", "-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 t (Metadata m) = do + v <- m !? toLower t + guard (v /= String "-") -- Marked for deletion, see del function below. + fromValue 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 t v (Metadata m) = Metadata $ insert (toLower t) (toValue v) 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 t = set t (String "-") + +-- | Extract content from Right or throw error. +eitherError :: Either Text a -> a +eitherError = either (error . into @String) id diff --git a/src/ExifTool.hs b/src/ExifTool.hs deleted file mode 100644 --- a/src/ExifTool.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- | --- Module : ExifTool --- Copyright : (c) Martin Hoppenheit 2020-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 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.Bifunctor (bimap) -import System.IO (Handle, hFlush, hReady) - -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.ByteString (ByteString) -import Data.ByteString.Base64 (decodeBase64, encodeBase64) -import Data.ByteString.Lazy (hPut) -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.String.Conversions (cs) -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.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. Use 'get', 'set' and 'del' to query and --- manipulate this set. -newtype Metadata = Metadata (HashMap Tag Value) - deriving (Show, Eq) - deriving (Semigroup, Monoid) via (HashMap Tag Value) - --- | An ExifTool tag name like @Tag "Description"@ or @Tag --- "EXIF:IFD0:XResolution"@. -newtype Tag = Tag {tagName :: Text} - deriving (Show, Eq) - deriving (Hashable, FromJSON, FromJSONKey, ToJSON, 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 . last . splitOn ":" . tagName - --- | Make a tag name lower case. -toLower :: Tag -> Tag -toLower = Tag . toCaseFold . 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 (Show, Eq) - -instance FromJSON Value where - parseJSON (JSON.String x) - | Just b <- stripPrefix "base64:" x = - either (fail . cs) (pure . Binary) (decodeBase64 $ cs b) - | otherwise = pure $ String x - parseJSON (JSON.Number x) = pure $ Number x - parseJSON (JSON.Bool x) = pure $ Bool x - parseJSON (JSON.Array xs) = List . Vector.toList <$> traverse parseJSON xs - parseJSON JSON.Null = pure $ String "" - -- parseJSON (JSON.Object x) = Struct <$> sequence (fmap parseJSON x) - parseJSON x = fail $ "error parsing ExifTool JSON output: " <> show x - -instance ToJSON Value where - toJSON (String x) = JSON.String x - toJSON (Binary x) = JSON.String $ "base64:" <> encodeBase64 x - toJSON (Number x) = JSON.Number x - toJSON (Bool x) = JSON.Bool x - toJSON (List xs) = JSON.Array . Vector.fromList $ map toJSON xs - toEncoding (String x) = text x - toEncoding (Binary x) = text $ "base64:" <> encodeBase64 x - toEncoding (Number x) = scientific x - toEncoding (Bool x) = bool x - toEncoding (List xs) = list toEncoding 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 = Just - -instance ToValue Value where - toValue = id - -instance FromValue Text where - fromValue (String x) = Just x - fromValue (Binary x) = either (const Nothing) Just $ decodeUtf8' x - fromValue (Number x) = - Just . cs . formatScientific Fixed (Just $ if isInteger x then 0 else 2) $ x - fromValue (Bool x) = Just . cs . show $ x - fromValue (List xs) = intercalate ", " <$> traverse fromValue xs - -instance ToValue Text where - toValue = String - -instance FromValue ByteString where - fromValue (Binary x) = Just x - fromValue _ = Nothing - -instance ToValue ByteString where - toValue = Binary - -instance FromValue Int where - fromValue (Number x) = toBoundedInteger x - fromValue _ = Nothing - -instance ToValue Int where - toValue = Number . fromIntegral - -instance FromValue Integer where - fromValue x = fromIntegral <$> (fromValue x :: Maybe Int) - -instance ToValue Integer where - toValue = Number . fromIntegral - -instance FromValue Float where - fromValue (Number x) = Just $ toRealFloat x - fromValue _ = Nothing - -instance ToValue Float where - toValue = Number . fromFloatDigits - -instance FromValue Double where - fromValue (Number x) = Just $ toRealFloat x - fromValue _ = Nothing - -instance ToValue Double where - toValue = Number . fromFloatDigits - -instance FromValue Bool where - fromValue (Bool x) = Just x - fromValue _ = Nothing - -instance ToValue Bool where - toValue = Bool - -instance FromValue a => FromValue [a] where - fromValue (List xs) = traverse fromValue xs - fromValue _ = Nothing - -instance ToValue a => ToValue [a] where - toValue = List . fmap toValue - --- | Start an ExifTool instance. Use 'stopExifTool' when done, or 'withExifTool' --- to combine both steps. -startExifTool :: IO ExifTool -startExifTool = do - (Just i, Just o, Just e, p) <- createProcess conf - pure $ ET i o e p - where - conf = - (proc "exiftool" options) - { std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - options = ["-stay_open", "True", "-@", "-"] - --- | Stop a running ExifTool instance. -stopExifTool :: ExifTool -> IO () -stopExifTool (ET i o e p) = do - hPutStrLn i "-stay_open" - hPutStrLn i "False" - hFlush i - cleanupProcess (Just i, Just o, Just e, p) - --- | Start an ExifTool instance, do something with it, then stop it. -withExifTool :: (ExifTool -> IO a) -> IO a -withExifTool = bracket startExifTool 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 (ET i o e _) cmds = do - mapM_ (hPutStrLn i) cmds - hPutStrLn i "-execute" - hFlush i - -- Do not switch the order of readOut/readErr lest we miss errors! - out <- readOut o "" - err <- readErr e "" - pure $ - if isError err - then Left err - else Right out - where - readOut :: Handle -> Text -> IO Text - readOut h acc = do - l <- hGetLine h - if "{ready}" `isPrefixOf` l - then pure acc - else readOut h (acc <> l) - readErr :: Handle -> Text -> IO Text - readErr h acc = do - hasMore <- hReady h - if not hasMore - then pure acc - else do - l <- hGetLine h - readErr h (acc <> l) - isError :: Text -> Bool - isError t = t `notElem` ["", " 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 et ts fp = eitherError <$> readMetaEither et ts 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 et ts fp = do - result <- sendCommand et (cs fp : options <> tags) - pure $ Metadata . mapKeys toLower <$> (result >>= parseOutput) - where - options = ["-json", "-binary", "-unknown2"] - tags = fmap (("-" <>) . tagName) ts - parseOutput = bimap cs head . eitherDecode . cs - --- | 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 et m fp = eitherError <$> writeMetaEither et m 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 et (Metadata m) fp = - withSystemTempFile "exiftool.json" $ \metafile h -> do - hPut h $ encode [delete (Tag "SourceFile") m] - hFlush h - void <$> sendCommand et (cs fp : "-json=" <> cs metafile : options) - where - options = ["-overwrite_original", "-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 t (Metadata m) = do - v <- m !? toLower t - guard (v /= String "-") -- Marked for deletion, see del function below. - fromValue 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 t v (Metadata m) = Metadata $ insert (toLower t) (toValue v) 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 t = set t (String "-") - --- | Extract content from Right or throw error. -eitherError :: Either Text a -> a -eitherError = either (error . cs) id