{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
module ExifTool
(
ExifTool,
startExifTool,
stopExifTool,
withExifTool,
readMeta,
readMetaEither,
writeMeta,
writeMetaEither,
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.Base64.Types (extractBase64)
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (decodeBase64Untyped, 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,
pack,
splitOn,
stripPrefix,
toCaseFold,
unpack,
)
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
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,
)
data ExifTool
= ET
!Handle
!Handle
!Handle
!ProcessHandle
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
$cshowsPrec :: Int -> Metadata -> ShowS
showsPrec :: Int -> Metadata -> ShowS
$cshow :: Metadata -> String
show :: Metadata -> String
$cshowList :: [Metadata] -> ShowS
showList :: [Metadata] -> ShowS
Show, Metadata -> Metadata -> Bool
(Metadata -> Metadata -> Bool)
-> (Metadata -> Metadata -> Bool) -> Eq Metadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Metadata -> Metadata -> Bool
== :: Metadata -> Metadata -> Bool
$c/= :: Metadata -> Metadata -> Bool
/= :: Metadata -> Metadata -> Bool
Eq)
deriving (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
$c<> :: Metadata -> Metadata -> Metadata
<> :: Metadata -> Metadata -> Metadata
$csconcat :: NonEmpty Metadata -> Metadata
sconcat :: NonEmpty Metadata -> Metadata
$cstimes :: forall b. Integral b => b -> Metadata -> Metadata
stimes :: forall b. Integral b => b -> 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
$cmempty :: Metadata
mempty :: Metadata
$cmappend :: Metadata -> Metadata -> Metadata
mappend :: Metadata -> Metadata -> Metadata
$cmconcat :: [Metadata] -> Metadata
mconcat :: [Metadata] -> Metadata
Monoid) via (HashMap Tag Value)
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
$cshowsPrec :: Int -> Tag -> ShowS
showsPrec :: Int -> Tag -> ShowS
$cshow :: Tag -> String
show :: Tag -> String
$cshowList :: [Tag] -> ShowS
showList :: [Tag] -> ShowS
Show, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
/= :: 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
$chashWithSalt :: Int -> Tag -> Int
hashWithSalt :: Int -> Tag -> Int
$chash :: Tag -> Int
hash :: Tag -> Int
Hashable, Maybe Tag
Value -> Parser [Tag]
Value -> Parser Tag
(Value -> Parser Tag)
-> (Value -> Parser [Tag]) -> Maybe Tag -> FromJSON Tag
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Tag
parseJSON :: Value -> Parser Tag
$cparseJSONList :: Value -> Parser [Tag]
parseJSONList :: Value -> Parser [Tag]
$comittedField :: Maybe Tag
omittedField :: Maybe Tag
FromJSON, FromJSONKeyFunction [Tag]
FromJSONKeyFunction Tag
FromJSONKeyFunction Tag
-> FromJSONKeyFunction [Tag] -> FromJSONKey Tag
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction Tag
fromJSONKey :: FromJSONKeyFunction Tag
$cfromJSONKeyList :: FromJSONKeyFunction [Tag]
fromJSONKeyList :: FromJSONKeyFunction [Tag]
FromJSONKey, [Tag] -> Value
[Tag] -> Encoding
Tag -> Bool
Tag -> Value
Tag -> Encoding
(Tag -> Value)
-> (Tag -> Encoding)
-> ([Tag] -> Value)
-> ([Tag] -> Encoding)
-> (Tag -> Bool)
-> ToJSON Tag
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Tag -> Value
toJSON :: Tag -> Value
$ctoEncoding :: Tag -> Encoding
toEncoding :: Tag -> Encoding
$ctoJSONList :: [Tag] -> Value
toJSONList :: [Tag] -> Value
$ctoEncodingList :: [Tag] -> Encoding
toEncodingList :: [Tag] -> Encoding
$comitField :: Tag -> Bool
omitField :: Tag -> Bool
ToJSON, ToJSONKeyFunction [Tag]
ToJSONKeyFunction Tag
ToJSONKeyFunction Tag -> ToJSONKeyFunction [Tag] -> ToJSONKey Tag
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction Tag
toJSONKey :: ToJSONKeyFunction Tag
$ctoJSONKeyList :: ToJSONKeyFunction [Tag]
toJSONKeyList :: ToJSONKeyFunction [Tag]
ToJSONKey) via Text
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. HasCallStack => [a] -> a
last ([Text] -> Text) -> (Tag -> [Text]) -> Tag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
":" (Text -> [Text]) -> (Tag -> Text) -> Tag -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
tagName
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
data Value
= String !Text
| Binary !ByteString
| Number !Scientific
| Bool !Bool
| List ![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
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: 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 a. String -> Parser a
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
. Text -> String
unpack)
(Value -> Parser Value
forall a. a -> Parser a
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
decodeBase64Untyped (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
b)
| Bool
otherwise = Value -> Parser Value
forall a. a -> Parser a
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 a. a -> Parser a
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 a. a -> Parser a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse Value -> Parser Value
forall a. FromJSON a => Value -> Parser a
parseJSON Array
xs
parseJSON Value
JSON.Null = Value -> Parser Value
forall a. a -> Parser a
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 Value
x = String -> Parser Value
forall a. String -> Parser a
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
<> Base64 'StdPadded Text -> Text
forall (k :: Alphabet) a. Base64 k a -> a
extractBase64 (ByteString -> Base64 'StdPadded 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
<> Base64 'StdPadded Text -> Text
forall (k :: Alphabet) a. Base64 k a -> a
extractBase64 (ByteString -> Base64 'StdPadded 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
class FromValue a where
fromValue :: Value -> Maybe a
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
. String -> Text
pack
(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
. String -> Text
pack (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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. ToValue a => a -> Value
toValue
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 a. a -> IO a
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 = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe
}
options :: [String]
options = [String
"-stay_open", String
"True", String
"-@", String
"-"]
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)
withExifTool :: (ExifTool -> IO a) -> IO a
withExifTool :: forall a. (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
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
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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"]
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
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
pack 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 a. a -> IO a
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 a b. Either Text a -> (a -> Either Text b) -> Either Text b
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 a b. (a -> b) -> [a] -> [b]
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 a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap String -> Text
pack [HashMap Tag Value] -> HashMap Tag Value
forall a. HasCallStack => [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
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
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
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
pack String
fp Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"-json=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
metafile Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
options)
where
options :: [Text]
options = [Text
"-overwrite_original", Text
"-f"]
get :: (FromValue a) => Tag -> Metadata -> Maybe a
get :: forall a. FromValue a => 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
"-")
Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromValue Value
v
set :: (ToValue a) => Tag -> a -> Metadata -> Metadata
set :: forall a. ToValue a => 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
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
"-")
eitherError :: Either Text a -> a
eitherError :: forall a. 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
. Text -> String
unpack) a -> a
forall a. a -> a
id