{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Graphics.HsExif (
parseFileExif,
parseExif,
readExifDateTime,
getDateTimeOriginal,
getOrientation,
ImageOrientation(..),
RotationDirection(..),
getGpsLatitudeLongitude,
wasFlashFired,
formatAsFloatingPoint,
getGpsDateTime,
parseGpsTime,
ExifValue(..),
exposureTime,
fnumber,
isoSpeedRatings,
dateTimeOriginal,
shutterSpeedValue,
apertureValue,
brightnessValue,
exposureBiasValue,
maxApertureValue,
flash,
focalLength,
userComment,
orientation,
make,
model,
software,
copyright,
digitalZoomRatio,
focalLengthIn35mmFilm,
artist,
gpsVersionID,
gpsLatitudeRef,
gpsLatitude,
gpsLongitudeRef,
gpsLongitude,
gpsAltitudeRef,
gpsAltitude,
gpsTimeStamp,
gpsSatellites,
gpsStatus,
gpsMeasureMode,
gpsDop,
gpsSpeedRef,
gpsSpeed,
gpsTrackRef,
gpsTrack,
gpsImgDirectionRef,
gpsImgDirection,
gpsMapDatum,
gpsDestLatitudeRef,
gpsDestLatitude,
gpsDestLongitudeRef,
gpsDestLongitude,
gpsDestBearingRef,
gpsDestBearing,
gpsDestDistanceRef,
gpsDestDistance,
gpsProcessingMethod,
gpsAreaInformation,
gpsDateStamp,
gpsDifferential,
exifVersion,
sensingMethod,
fileSource,
sceneType,
makerNote,
subjectDistance,
meteringMode,
lightSource,
exifImageWidth,
exifImageHeight,
relatedSoundFile,
focalPlaneXResolution,
focalPlaneYResolution,
focalPlaneResolutionUnit,
dateTimeDigitized,
componentConfiguration,
compressedBitsPerPixel,
exposureProgram,
spectralSensitivity,
oecf,
subjectArea,
subSecTime,
subSecTimeOriginal,
subSecTimeDigitized,
flashPixVersion,
colorSpace,
flashEnergy,
spatialFrequencyResponse,
subjectLocation,
exposureIndex,
cfaPattern,
customRendered,
exposureMode,
whiteBalance,
sceneCaptureType,
gainControl,
contrast,
saturation,
sharpness,
deviceSettingDescription,
subjectDistanceRange,
imageUniqueId,
exifInteroperabilityOffset,
imageDescription,
xResolution,
yResolution,
resolutionUnit,
dateTime,
whitePoint,
primaryChromaticities,
yCbCrPositioning,
yCbCrCoefficients,
referenceBlackWhite,
printImageMatching,
ExifTag(..),
TagLocation(..),
) where
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import Control.Monad
import Control.Applicative ( (<$>) )
import qualified Data.ByteString.Char8 as Char8
import Data.ByteString.Internal (w2c)
import Data.Word
import Data.Char (ord)
import Data.Int (Int32, Int16, Int8)
import Data.List
import Data.Maybe (fromMaybe, fromJust)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Time.LocalTime
import Data.Time.Calendar
import Data.Bits ((.&.))
import Control.Exception
import System.IO
import Graphics.Types (ExifValue(..), ExifTag(..), TagLocation(..), formatAsFloatingPoint)
import Graphics.ExifTags
import Graphics.Helpers
parseFileExif :: FilePath -> IO (Either String (Map ExifTag ExifValue))
parseFileExif filename = withFile filename ReadMode ((evaluate =<<) . fmap parseExif . B.hGetContents)
parseExif :: B.ByteString -> Either String (Map ExifTag ExifValue)
parseExif = runEitherGet getExif
getExif :: Get (Map ExifTag ExifValue)
getExif = do
firstBytes <- lookAhead $ (,) <$> getWord16be <*> getWord16be
case firstBytes of
(0xffd8,_ ) -> getWord16be >> findAndParseExifBlockJPEG
(0x4d4d,0x002A) -> findAndParseExifBlockTiff
(0x4949,0x2A00) -> findAndParseExifBlockTiff
(0x4949,0x524F) -> findAndParseExifBlockTiff
(0x4949,0x5500) -> findAndParseExifBlockTiff
(0x4655,0x4A49) -> findAndParseExifBlockFuji
_ -> fail "Not a JPEG, TIFF, RAF, or TIFF-based raw file"
findAndParseExifBlockJPEG :: Get (Map ExifTag ExifValue)
findAndParseExifBlockJPEG = do
markerNumber <- getWord16be
dataSize <- fromIntegral . toInteger <$> getWord16be
case markerNumber of
0xffe1 -> tryParseExifBlock >>= \case
Right exif -> pure exif
Left bytesReadByTry -> skip (dataSize - 2 - bytesReadByTry) >> findAndParseExifBlockJPEG
0xffda -> fail "No EXIF in JPEG"
_ -> skip (dataSize-2) >> findAndParseExifBlockJPEG
findAndParseExifBlockTiff :: Get (Map ExifTag ExifValue)
findAndParseExifBlockTiff = parseTiff
findAndParseExifBlockFuji :: Get (Map ExifTag ExifValue)
findAndParseExifBlockFuji = do
header <- getByteString 16
version <- getByteString 4
skip 64
jpegOffset <- getWord32be
unless (header == "FUJIFILMCCD-RAW " && version == "0201") $ fail "Incorrect RAF header"
skip $
fromIntegral jpegOffset
- 16
- 4
- 64
- 4
+ 2
findAndParseExifBlockJPEG
data ByteAlign = Intel | Motorola deriving (Eq)
getWord16 :: ByteAlign -> Get Word16
getWord16 Intel = getWord16le
getWord16 Motorola = getWord16be
getWord32 :: ByteAlign -> Get Word32
getWord32 Intel = getWord32le
getWord32 Motorola = getWord32be
putWord32 :: ByteAlign -> Word32 -> Put
putWord32 Intel = putWord32le
putWord32 Motorola = putWord32be
tryParseExifBlock :: Get (Either Int (Map ExifTag ExifValue))
tryParseExifBlock = do
header <- getByteString 4
nul <- toInteger <$> getWord16be
if header == Char8.pack "Exif" && nul == 0
then Right <$> parseTiff
else pure (Left 6)
parseTiff :: Get (Map ExifTag ExifValue)
parseTiff = do
(byteAlign, ifdOffset) <- lookAhead parseTiffHeader
tags <- parseIfd byteAlign IFD0 ifdOffset
return $ Map.fromList tags
parseTiffHeader :: Get (ByteAlign, Int)
parseTiffHeader = do
byteAlignV <- Char8.unpack <$> getByteString 2
byteAlign <- case byteAlignV of
"II" -> return Intel
"MM" -> return Motorola
_ -> fail $ "Unknown byte alignment: " ++ byteAlignV
alignControl <- toInteger <$> getWord16 byteAlign
unless (alignControl == 0x2a || (byteAlign == Intel && (alignControl == 0x55 || alignControl == 0x4f52)))
$ fail "exif byte alignment mismatch"
ifdOffset <- fromIntegral . toInteger <$> getWord32 byteAlign
return (byteAlign, ifdOffset)
parseIfd :: ByteAlign -> TagLocation -> Int -> Get [(ExifTag, ExifValue)]
parseIfd byteAlign ifdId offset = do
entries <- lookAhead $ do
skip offset
dirEntriesCount <- fromIntegral <$> getWord16 byteAlign
replicateM dirEntriesCount (parseIfEntry byteAlign ifdId)
concat <$> mapM (entryTags byteAlign) entries
entryTags :: ByteAlign -> IfEntry -> Get [(ExifTag, ExifValue)]
entryTags _ (Tag tag parseValue) = parseValue >>= \value -> pure [(tag, value)]
entryTags byteAlign (SubIFD ifdId offset) = lookAhead (parseIfd byteAlign ifdId offset)
data IfEntry = Tag ExifTag (Get ExifValue) | SubIFD TagLocation Int
parseIfEntry :: ByteAlign -> TagLocation -> Get IfEntry
parseIfEntry byteAlign ifdId = do
tagNumber <- getWord16 byteAlign
format <- getWord16 byteAlign
numComponents <- fromIntegral <$> getWord32 byteAlign
content <- getWord32 byteAlign
return $ case (ifdId, tagNumber) of
(IFD0, 0x8769) -> SubIFD ExifSubIFD (fromIntegral content)
(IFD0, 0x8825) -> SubIFD GpsSubIFD (fromIntegral content)
(_, tagId) -> Tag (getExifTag ifdId tagId) (decodeEntry byteAlign format numComponents content)
getExifTag :: TagLocation -> Word16 -> ExifTag
getExifTag l v = fromMaybe (ExifTag l Nothing v showT) $ find (isSameTag l v) allExifTags
where isSameTag l1 v1 (ExifTag l2 _ v2 _) = l1 == l2 && v1 == v2
data ValueHandler = ValueHandler
{
dataTypeId :: Word16,
dataLength :: Int,
readSingle :: ByteAlign -> Get ExifValue,
readMany :: ByteAlign -> Int -> Get ExifValue
}
readNumberList :: Integral a => (ByteAlign -> Get a) -> ByteAlign -> Int -> Get ExifValue
readNumberList decoder byteAlign components = ExifNumberList . fmap fromIntegral <$>
count components (decoder byteAlign)
decodeTextByteString :: BS.ByteString -> String
decodeTextByteString bs = w2c <$> strippedWords
where
strippedWords = if not (null bsWords) && last bsWords == 0
then init bsWords
else bsWords
bsWords = BS.unpack bs
unsignedByteValueHandler = ValueHandler
{
dataTypeId = 1,
dataLength = 1,
readSingle = \_ -> ExifNumber . fromIntegral <$> getWord8,
readMany = readNumberList $ const getWord8
}
asciiStringValueHandler = ValueHandler
{
dataTypeId = 2,
dataLength = 1,
readSingle = \ba -> readMany asciiStringValueHandler ba 1,
readMany = \_ components -> ExifText . decodeTextByteString <$> getByteString components
}
unsignedShortValueHandler = ValueHandler
{
dataTypeId = 3,
dataLength = 2,
readSingle = liftM (ExifNumber . fromIntegral) . getWord16,
readMany = readNumberList getWord16
}
unsignedLongValueHandler = ValueHandler
{
dataTypeId = 4,
dataLength = 4,
readSingle = liftM (ExifNumber . fromIntegral) . getWord32,
readMany = readNumberList getWord32
}
readRationalContents :: (Int -> Int -> a) -> ByteAlign -> Get a
readRationalContents c byteAlign = do
numerator <- fromIntegral <$> getWord32 byteAlign
denominator <- fromIntegral <$> getWord32 byteAlign
return $ c numerator denominator
unsignedRationalValueHandler = ValueHandler
{
dataTypeId = 5,
dataLength = 8,
readSingle = readRationalContents ExifRational,
readMany = \byteAlign components -> ExifRationalList <$> count components (readRationalContents (,) byteAlign)
}
signedByteValueHandler = ValueHandler
{
dataTypeId = 6,
dataLength = 1,
readSingle = \_ -> ExifNumber . signedInt8ToInt <$> getWord8,
readMany = readNumberList (liftM signedInt8ToInt . const getWord8)
}
undefinedValueHandler = ValueHandler
{
dataTypeId = 7,
dataLength = 1,
readSingle = \ba -> readMany undefinedValueHandler ba 1,
readMany = \_ components -> ExifUndefined <$> getByteString components
}
signedShortValueHandler = ValueHandler
{
dataTypeId = 8,
dataLength = 2,
readSingle = liftM (ExifNumber . signedInt16ToInt) . getWord16,
readMany = readNumberList (liftM signedInt16ToInt . getWord16)
}
signedLongValueHandler = ValueHandler
{
dataTypeId = 9,
dataLength = 4,
readSingle = liftM (ExifNumber . signedInt32ToInt) . getWord32,
readMany = readNumberList (liftM signedInt32ToInt . getWord32)
}
readSignedRationalContents :: (Int -> Int -> a) -> ByteAlign -> Get a
readSignedRationalContents c byteAlign = do
numerator <- signedInt32ToInt <$> getWord32 byteAlign
denominator <- signedInt32ToInt <$> getWord32 byteAlign
return $ c numerator denominator
signedRationalValueHandler = ValueHandler
{
dataTypeId = 10,
dataLength = 8,
readSingle = readSignedRationalContents ExifRational,
readMany = \byteAlign components -> ExifRationalList <$>
count components (readSignedRationalContents (,) byteAlign)
}
valueHandlers :: [ValueHandler]
valueHandlers =
[
unsignedByteValueHandler,
asciiStringValueHandler,
unsignedShortValueHandler,
unsignedLongValueHandler,
unsignedRationalValueHandler,
signedByteValueHandler,
signedShortValueHandler,
signedLongValueHandler,
signedRationalValueHandler,
undefinedValueHandler
]
decodeEntry :: ByteAlign -> Word16 -> Int -> Word32 -> Get ExifValue
decodeEntry byteAlign format amount payload = do
case getHandler format of
Just handler | isInline handler -> return $ parseInline byteAlign handler amount (runPut $ putWord32 byteAlign payload)
Just handler -> parseOffset byteAlign handler amount payload
Nothing -> return $ ExifUnknown format amount (fromIntegral payload)
where
isInline handler = dataLength handler * amount <= 4
getHandler :: Word16 -> Maybe ValueHandler
getHandler typeId = find ((==typeId) . dataTypeId) valueHandlers
parseInline :: ByteAlign -> ValueHandler -> Int -> B.ByteString -> ExifValue
parseInline byteAlign handler amount bytestring =
fromJust $ runMaybeGet getter bytestring
where
getter = case amount of
1 -> readSingle handler byteAlign
_ -> readMany handler byteAlign amount
parseOffset :: ByteAlign -> ValueHandler -> Int -> Word32 -> Get ExifValue
parseOffset byteAlign handler amount offset = do
lookAhead $ do
skip (fromIntegral offset)
let bsLength = amount * dataLength handler
bytestring <- getLazyByteString (fromIntegral bsLength)
return (parseInline byteAlign handler amount bytestring)
signedInt32ToInt :: Word32 -> Int
signedInt32ToInt w = fromIntegral (fromIntegral w :: Int32)
signedInt16ToInt :: Word16 -> Int
signedInt16ToInt w = fromIntegral (fromIntegral w :: Int16)
signedInt8ToInt :: Word8 -> Int
signedInt8ToInt w = fromIntegral (fromIntegral w :: Int8)
readExifDateTime :: String -> Maybe LocalTime
readExifDateTime dateStr = runMaybeGet getExifDateTime $ B.pack $ map (fromIntegral . ord) dateStr
getExifDateTime :: Get LocalTime
getExifDateTime = do
year <- readDigit 4
month <- getCharValue ':' >> readDigit 2
day <- getCharValue ':' >> readDigit 2
hour <- getCharValue ' ' >> readDigit 2
minute <- getCharValue ':' >> readDigit 2
second <- getCharValue ':' >> readDigit 2
return $ LocalTime (fromGregorian year month day) (TimeOfDay hour minute second)
getDateTimeOriginal :: Map ExifTag ExifValue -> Maybe LocalTime
getDateTimeOriginal exifData = Map.lookup dateTimeOriginal exifData >>= readExifDateTime . show
data RotationDirection = MinusNinety
| Ninety
| HundredAndEighty
deriving (Show, Eq)
data ImageOrientation = Normal
| Mirror
| Rotation RotationDirection
| MirrorRotation RotationDirection
deriving (Show, Eq)
getOrientation :: Map ExifTag ExifValue -> Maybe ImageOrientation
getOrientation exifData = do
rotationVal <- Map.lookup orientation exifData
case rotationVal of
ExifNumber 1 -> Just Normal
ExifNumber 2 -> Just Mirror
ExifNumber 3 -> Just $ Rotation HundredAndEighty
ExifNumber 4 -> Just $ MirrorRotation HundredAndEighty
ExifNumber 5 -> Just $ MirrorRotation MinusNinety
ExifNumber 6 -> Just $ Rotation MinusNinety
ExifNumber 7 -> Just $ MirrorRotation Ninety
ExifNumber 8 -> Just $ Rotation Ninety
_ -> Nothing
wasFlashFired :: Map ExifTag ExifValue -> Maybe Bool
wasFlashFired exifData = Map.lookup flash exifData >>= \case
ExifNumber n -> Just $ n .&. 1 /= 0
_ -> Nothing