diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /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 --- /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 100644 --- /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 --- /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 --- /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 --- /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 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