exiftool 0.2.0.0 → 0.2.0.1
raw patch · 5 files changed
+443/−429 lines, 5 filesdep +witchdep −string-conversionsdep ~aesondep ~textdep ~vectorPVP ok
version bump matches the API change (PVP)
Dependencies added: witch
Dependencies removed: string-conversions
Dependency ranges changed: aeson, text, vector
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- LICENSE +1/−1
- exiftool.cabal +31/−33
- lib/ExifTool.hs +407/−0
- src/ExifTool.hs +0/−395
CHANGELOG.md view
@@ -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:
LICENSE view
@@ -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
exiftool.cabal view
@@ -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
+ lib/ExifTool.hs view
@@ -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
− src/ExifTool.hs
@@ -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