summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMartinHoppenheit <>2020-09-14 20:16:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-09-14 20:16:00 (GMT)
commit12ecd14fc87161b86ea2ba7c9d19adfeb749c64f (patch)
treec9c8d8ac1570930a12d3b1f98924ec490566af08
version 0.1.0.0HEAD0.1.0.0master
-rwxr-xr-xCHANGELOG.md5
-rw-r--r--LICENSE21
-rwxr-xr-xREADME.md5
-rw-r--r--Setup.hs2
-rw-r--r--exiftool.cabal39
-rw-r--r--src/ExifTool.hs365
6 files changed, 437 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..a27a5bd
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for exiftool
+
+## 0.1.0.0 -- 2020-09-14
+
+* Initial release.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c4fdc26
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2020 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
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100755
index 0000000..01a241d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,5 @@
+# exiftool-haskell
+
+Haskell bindings to the [ExifTool](https://exiftool.org) command-line
+application that enable reading, writing and deleting metadata in various file
+formats.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/exiftool.cabal b/exiftool.cabal
new file mode 100644
index 0000000..dd4bbfa
--- /dev/null
+++ b/exiftool.cabal
@@ -0,0 +1,39 @@
+name: exiftool
+version: 0.1.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 Martin Hoppenheit
+category: Foreign
+build-type: Simple
+extra-source-files: README.md
+ , CHANGELOG.md
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules: ExifTool
+ default-language: Haskell2010
+ ghc-options: -Wall
+ build-depends: base >= 4.13 && < 5
+ , aeson >= 1.5.4 && < 1.6
+ , base64 >= 0.4.2 && < 0.5
+ , bytestring >= 0.10.10 && < 0.11
+ , hashable >= 1.3.0 && < 1.4
+ , process >= 1.6.9 && < 1.7
+ , scientific >= 0.3.6 && < 0.4
+ , string-conversions >= 0.4.0 && < 0.5
+ , temporary >= 1.3 && < 1.4
+ , text >= 1.2.4 && < 1.3
+ , unordered-containers >= 0.2.12 && < 0.3
+ , vector >= 0.12.1 && < 0.13
+
+source-repository head
+ type: git
+ location: https://github.com/marhop/exiftool-haskell
diff --git a/src/ExifTool.hs b/src/ExifTool.hs
new file mode 100644
index 0000000..635eead
--- /dev/null
+++ b/src/ExifTool.hs
@@ -0,0 +1,365 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TupleSections #-}
+
+-- |
+-- Module : ExifTool
+-- Copyright : (c) Martin Hoppenheit 2020
+-- 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 #-}
+-- > {-# LANGUAGE OverloadedLists #-}
+-- >
+-- > import ExifTool
+-- > import Data.HashMap.Strict ((!?))
+-- >
+-- > example :: IO ()
+-- > example =
+-- > withExifTool $ \et -> do
+-- > -- Read metadata, with exact (!?) and fuzzy (~~) tag lookup.
+-- > m <- getMeta et "a.jpg"
+-- > print $ m !? Tag "EXIF" "ExifIFD" "DateTimeOriginal"
+-- > print $ m ~~ Tag "EXIF" "" "XResolution"
+-- > print $ m ~~ Tag "XMP" "" ""
+-- > -- Write and delete metadata.
+-- > setMeta et [(Tag "XMP" "XMP-dc" "Description", String "...")] "a.jpg"
+-- > deleteMeta et [Tag "XMP" "XMP-dc" "Description"] "a.jpg"
+--
+-- Note that this module expects the @exiftool@ binary to be in your PATH.
+
+module ExifTool
+ ( -- * Running an ExifTool instance
+ --
+ -- | Most functions in this module interact with an ExifTool instance
+ -- i.e., a running ExifTool process represented by the 'ExifTool' data
+ -- type. The easiest way to obtain an instance is the 'withExifTool'
+ -- function that takes care of starting and stopping the process.
+ ExifTool
+ , startExifTool
+ , stopExifTool
+ , withExifTool
+ -- * Reading and writing metadata
+ --
+ -- | The ExifTool instance can then be used to read, write or delete
+ -- metadata in a file with the respective functions. These come in two
+ -- variants, one that throws runtime errors when the ExifTool process
+ -- returns error messages and one that instead produces Either values.
+ -- Choose those that best fit your use case.
+ , getMeta
+ , setMeta
+ , deleteMeta
+ , getMetaEither
+ , setMetaEither
+ , deleteMetaEither
+ -- * Data types and utility functions
+ --
+ -- | Metadata is represented by a 'Data.HashMap.Strict.HashMap' of
+ -- 'Tag'/'Value' pairs (with alias 'Metadata'), so it is advisable to
+ -- import some functions like 'Data.HashMap.Strict.lookup' or
+ -- 'Data.HashMap.Strict.!?' from the "Data.HashMap.Strict" module. The
+ -- ExifTool module defines additional utility functions that make working
+ -- with Metadata easier.
+ , Metadata
+ , Tag(..)
+ , Value(..)
+ , filterByTag
+ , (~~)
+ ) where
+
+import Control.Exception (bracket)
+import Control.Monad (void)
+import qualified Data.Aeson as JSON
+import Data.Aeson
+ ( FromJSON(..)
+ , FromJSONKey(..)
+ , FromJSONKeyFunction(..)
+ , ToJSON(..)
+ , ToJSONKey(..)
+ , ToJSONKeyFunction(..)
+ , eitherDecode
+ , encode
+ )
+import Data.Aeson.Encoding.Internal (bool, list, scientific, text)
+import Data.Bifunctor (bimap)
+import Data.ByteString (ByteString)
+import Data.ByteString.Base64 (decodeBase64, encodeBase64)
+import Data.ByteString.Lazy (hPut)
+import Data.HashMap.Strict (HashMap, delete, filterWithKey, fromList)
+import Data.Hashable (Hashable)
+import Data.Scientific (Scientific)
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.IO (hGetLine, hPutStrLn)
+import qualified Data.Vector as Vector
+import GHC.Generics (Generic)
+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
+ )
+
+-- | An ExifTool instance, initialized with 'startExifTool' and terminated with
+-- 'stopExifTool'.
+data ExifTool = ET
+ !Handle -- ^ STDIN of this ExifTool process
+ !Handle -- ^ STDOUT of this ExifTool process
+ !Handle -- ^ STDERR of this ExifTool process
+ !ProcessHandle -- ^ process handle of this ExifTool process
+
+-- | A set of ExifTool tag/value pairs.
+type Metadata = HashMap Tag Value
+
+-- | An ExifTool tag name, consisting of three components:
+--
+-- 1. The family 0 tag group (information type) e.g., @EXIF@ or @XMP@.
+-- 2. The family 1 tag group (specific location) e.g., @IFD0@ or @XMP-dc@.
+-- 3. The actual tag name e.g., @XResolution@ or @Description@.
+--
+-- Example: @Tag \"EXIF\" \"IFD0\" \"XResolution\"@ corresponds to the ExifTool
+-- tag name @EXIF:IFD0:XResolution@.
+--
+-- During development, there are several ways to find the exact name of a tag:
+--
+-- * See <https://exiftool.org/#groups> for a list of tag groups.
+-- * Run something like @exiftool -s -a -G:0:1@.
+-- * Use the '~~' operator in ghci.
+data Tag = Tag
+ { tagFamily0 :: !Text -- ^ family 0 tag group
+ , tagFamily1 :: !Text -- ^ family 1 tag group
+ , tagName :: !Text -- ^ actual tag name
+ } deriving (Show, Eq, Generic, Hashable)
+
+instance FromJSON Tag where
+ parseJSON (JSON.String x)
+ | Just t <- readTag x = return t
+ parseJSON x = fail $ "unexpected formatting of ExifTool tag: " <> show x
+
+instance FromJSONKey Tag where
+ fromJSONKey = FromJSONKeyTextParser $ parseJSON . JSON.String
+
+instance ToJSON Tag where
+ toJSON = JSON.String . showTag
+ toEncoding = text . showTag
+
+instance ToJSONKey Tag where
+ toJSONKey = ToJSONKeyText showTag (text . showTag)
+
+-- | Parse an ExifTool tag name of the form @family0:family1:name@,
+-- @family0:name@ or @name@ (but /not/ @family1:name@).
+readTag :: Text -> Maybe Tag
+readTag t =
+ case T.splitOn ":" t of
+ [f0, f1, n] -> Just $ Tag f0 f1 n
+ [f0, n] -> Just $ Tag f0 "" n
+ [n] -> Just $ Tag "" "" n
+ _ -> Nothing
+
+-- | Format an ExifTool tag name in the form @family0:family1:name@,
+-- @family0:name@, @family1:name@ or @name@.
+showTag :: Tag -> Text
+showTag (Tag f0 f1 n) = T.intercalate ":" $ filter (not . T.null) [f0, f1, n]
+
+-- | An ExifTool tag value, enclosed in a type wrapper.
+data Value
+ = String !Text
+ | Binary !ByteString
+ | Number !Scientific
+ | Bool !Bool
+ | List ![Value]
+ -- Struct (Map Text Value)
+ deriving (Show, Eq)
+
+instance FromJSON Value where
+ parseJSON (JSON.String x)
+ | Just b <- T.stripPrefix "base64:" x =
+ either (fail . cs) (return . Binary) (decodeBase64 $ cs b)
+ | otherwise = return $ String x
+ parseJSON (JSON.Number x) = return $ Number x
+ parseJSON (JSON.Bool x) = return $ Bool x
+ parseJSON (JSON.Array xs) =
+ List <$> sequence (Vector.toList $ fmap parseJSON xs)
+ parseJSON JSON.Null = return $ 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
+
+-- | 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
+ return $ 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 ""
+ return $
+ if isError err
+ then Left err
+ else Right out
+ where
+ -- | Read from handle up to the string @{ready}@.
+ readOut :: Handle -> Text -> IO Text
+ readOut h acc = do
+ l <- hGetLine h
+ if "{ready}" `T.isPrefixOf` l
+ then return acc
+ else readOut h (acc <> l)
+ -- | Read /currently/ available data from handle, don't wait for more.
+ readErr :: Handle -> Text -> IO Text
+ readErr h acc = do
+ hasMore <- hReady h
+ if not hasMore
+ then return acc
+ else do
+ l <- hGetLine h
+ readErr h (acc <> l)
+ -- | Make sure an error string actually counts as error.
+ isError :: Text -> Bool
+ isError t = t `notElem` ["", " 1 image files updated"]
+
+-- | Read all metadata from a file, with ExifTool errors leading to runtime
+-- errors. (Use 'getMetaEither' instead if you would rather intercept them.)
+getMeta :: ExifTool -- ^ ExifTool instance
+ -> Text -- ^ file name
+ -> IO Metadata -- ^ tag/value Map
+getMeta et file = eitherError <$> getMetaEither et file
+
+-- | Read all metadata from a file, with ExifTool errors returned as Left
+-- values.
+getMetaEither :: ExifTool -- ^ ExifTool instance
+ -> Text -- ^ file name
+ -> IO (Either Text Metadata) -- ^ tag/value Map
+getMetaEither et file = do
+ result <- sendCommand et (file : options)
+ return $ result >>= parseOutput
+ where
+ parseOutput :: Text -> Either Text Metadata
+ parseOutput = bimap cs head . eitherDecode . cs
+ options = ["-json", "-a", "-G:0:1", "-s", "-binary"]
+
+-- | Write metadata to a file, with ExifTool errors leading to runtime errors.
+-- (Use 'setMetaEither' instead if you would rather intercept them.) The file is
+-- modified in place. Make sure you have the necessary backups!
+setMeta :: ExifTool -- ^ ExifTool instance
+ -> Metadata -- ^ tag/value Map
+ -> Text -- ^ file name
+ -> IO ()
+setMeta et m file = eitherError <$> setMetaEither et m file
+
+-- | Write metadata to a file, with ExifTool errors returned as Left values. The
+-- file is modified in place. Make sure you have the necessary backups!
+setMetaEither :: ExifTool -- ^ ExifTool instance
+ -> Metadata -- ^ tag/value Map
+ -> Text -- ^ file name
+ -> IO (Either Text ())
+setMetaEither et m file =
+ withSystemTempFile "exiftool.json" $ \metafile h -> do
+ hPut h $ encode [delete (Tag "" "" "SourceFile") m]
+ hFlush h
+ void <$> sendCommand et (file : "-json=" <> cs metafile : options)
+ where
+ options = ["-overwrite_original", "-f"]
+
+-- | Delete metadata from a file, with ExifTool errors leading to runtime
+-- errors. (Use 'deleteMetaEither' instead if you would rather intercept them.)
+-- The file is modified in place. Make sure you have the necessary backups!
+deleteMeta :: ExifTool -- ^ ExifTool instance
+ -> [Tag] -- ^ tags to be deleted
+ -> Text -- ^ file name
+ -> IO ()
+deleteMeta et ts file = eitherError <$> deleteMetaEither et ts file
+
+-- | Delete metadata from a file, with ExifTool errors returned as Left values.
+-- The file is modified in place. Make sure you have the necessary backups!
+deleteMetaEither :: ExifTool -- ^ ExifTool instance
+ -> [Tag] -- ^ tags to be deleted
+ -> Text -- ^ file name
+ -> IO (Either Text ())
+deleteMetaEither et ts = setMetaEither et (fromList $ fmap (, String "-") ts)
+
+-- | Filter metadata by tag name.
+filterByTag :: (Tag -> Bool) -> Metadata -> Metadata
+filterByTag p = filterWithKey (\t _ -> p t)
+
+-- | Filter metadata by fuzzy tag name matching. Tag names are matched ignoring
+-- case, and empty components of the given tag name are considered wildcards.
+-- Examples:
+--
+-- * @m ~~ Tag \"EXIF\" \"IFD0\" \"XResolution\"@ matches exactly the given tag
+-- name (ignoring case)
+-- * @m ~~ Tag "exif" "" "xresolution"@ matches all EXIF tags with name
+-- xresolution (ignoring case), including @EXIF:IFD0:XResolution@ and
+-- @EXIF:IFD1:XResolution@
+-- * @m ~~ Tag \"XMP\" "" ""@ matches all XMP tags
+--
+-- Note that @~~@ has higher precedence than '<>', so @m ~~ t <> m ~~ t' == (m
+-- ~~ t) <> (m ~~ t')@ which makes combining filters easy.
+--
+-- Hint: This operator is useful to find exact tag names in ghci.
+(~~) :: Metadata -> Tag -> Metadata
+infixl 8 ~~
+(~~) m t = filterByTag (match t) m
+ where
+ match :: Tag -> Tag -> Bool
+ match (Tag f0 f1 n) (Tag f0' f1' n') =
+ match' f0 f0' && match' f1 f1' && match' n n'
+ match' :: Text -> Text -> Bool
+ match' "" _ = True -- But not in reverse!
+ match' x x' = T.toCaseFold x == T.toCaseFold x'
+
+-- | Extract content from Right or throw error.
+eitherError :: Either Text a -> a
+eitherError = either (error . cs) id