module Graphics.HsExif (
parseFileExif,
parseExif,
readExifDateTime,
getDateTimeOriginal,
getOrientation,
ImageOrientation(..),
RotationDirection(..),
getGpsLatitudeLongitude,
wasFlashFired,
formatAsFloatingPoint,
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,
exifIfdOffset,
printImageMatching,
gpsTagOffset,
ExifTag(..),
TagLocation(..),
) where
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as B
import Control.Monad (liftM, unless, replicateM)
import qualified Data.ByteString.Char8 as Char8
import Data.Word
import Data.Char (isDigit, ord, chr)
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 Graphics.Types (ExifValue(..), ExifTag(..), TagLocation(..), formatAsFloatingPoint)
import Graphics.ExifTags
parseFileExif :: FilePath -> IO (Either String (Map ExifTag ExifValue))
parseFileExif filename = liftM parseExif $ B.readFile filename
parseExif :: B.ByteString -> Either String (Map ExifTag ExifValue)
parseExif contents = case runGetOrFail getExif contents of
Left (_,_,errorMsg) -> Left errorMsg
Right (_,_,result) -> Right result
getExif :: Get (Map ExifTag ExifValue)
getExif = do
header <- getWord16be
unless (header == 0xffd8)
$ fail "Not a JPEG file"
findAndParseExifBlock
findAndParseExifBlock :: Get (Map ExifTag ExifValue)
findAndParseExifBlock = do
markerNumber <- getWord16be
dataSize <- liftM (fromIntegral . toInteger) getWord16be
case markerNumber of
0xffe1 -> parseExifBlock
0xffda -> fail "No EXIF in JPEG"
_ -> skip (dataSize2) >> findAndParseExifBlock
data ByteAlign = Intel | Motorola
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
parseExifBlock :: Get (Map ExifTag ExifValue)
parseExifBlock = do
header <- getByteString 4
nul <- liftM toInteger getWord16be
unless (header == Char8.pack "Exif" && nul == 0)
$ fail "invalid EXIF header"
tiffHeaderStart <- liftM fromIntegral bytesRead
byteAlign <- parseTiffHeader
(exifSubIfdOffsetW, mGpsOffsetW, ifdEntries) <- parseIfd byteAlign tiffHeaderStart
let exifSubIfdOffset = fromIntegral $ toInteger exifSubIfdOffsetW
gpsData <- case mGpsOffsetW of
Nothing -> return []
Just gpsOffsetW -> lookAhead $ parseGps gpsOffsetW byteAlign tiffHeaderStart
bytesReadNow <- liftM fromIntegral bytesRead
skip $ (exifSubIfdOffset + tiffHeaderStart) bytesReadNow
exifSubEntries <- parseSubIfd byteAlign tiffHeaderStart ExifSubIFD
return $ Map.fromList $ ifdEntries ++ exifSubEntries ++ gpsData
parseGps :: Word32 -> ByteAlign -> Int -> Get [(ExifTag, ExifValue)]
parseGps gpsOffsetW byteAlign tiffHeaderStart = do
let gpsOffset = fromIntegral $ toInteger gpsOffsetW
bytesReadNow <- liftM fromIntegral bytesRead
skip $ (gpsOffset + tiffHeaderStart) bytesReadNow
parseSubIfd byteAlign tiffHeaderStart GpsSubIFD
parseTiffHeader :: Get ByteAlign
parseTiffHeader = do
byteAlignV <- getByteString 2
let byteAlign = case Char8.unpack byteAlignV of
"II" -> Intel
"MM" -> Motorola
_ -> error "Unknown byte alignment"
alignControl <- liftM toInteger (getWord16 byteAlign)
unless (alignControl == 0x2a)
$ fail "exif byte alignment mismatch"
ifdOffset <- liftM (fromIntegral . toInteger) (getWord32 byteAlign)
skip $ ifdOffset 8
return byteAlign
parseIfd :: ByteAlign -> Int -> Get (Word32, Maybe Word32, [(ExifTag, ExifValue)])
parseIfd byteAlign tiffHeaderStart = do
dirEntriesCount <- liftM toInteger (getWord16 byteAlign)
ifdEntries <- mapM (\_ -> parseIfEntry byteAlign) [1..dirEntriesCount]
let exifOffsetEntry = fromMaybe (error "Can't find the exif ifd offset")
(find (\ e -> entryTag e == tagKey exifIfdOffset) ifdEntries)
let exifOffset = entryContents exifOffsetEntry
let gpsOffsetEntry = find (\ e -> entryTag e == tagKey gpsTagOffset) ifdEntries
let gpsOffset = fmap entryContents gpsOffsetEntry
entries <- mapM (decodeEntry byteAlign tiffHeaderStart IFD0) ifdEntries
return (exifOffset, gpsOffset, entries)
parseSubIfd :: ByteAlign -> Int -> TagLocation -> Get [(ExifTag, ExifValue)]
parseSubIfd byteAlign tiffHeaderStart location = do
dirEntriesCount <- liftM toInteger (getWord16 byteAlign)
ifdEntries <- mapM (\_ -> parseIfEntry byteAlign) [1..dirEntriesCount]
mapM (decodeEntry byteAlign tiffHeaderStart location) ifdEntries
data IfEntry = IfEntry
{
entryTag :: !Word16,
entryFormat :: !Word16,
entryNoComponents :: !Int,
entryContents :: !Word32
} deriving Show
parseIfEntry :: ByteAlign -> Get IfEntry
parseIfEntry byteAlign = do
tagNumber <- getWord16 byteAlign
dataFormat <- getWord16 byteAlign
numComponents <- getWord32 byteAlign
value <- getWord32 byteAlign
return IfEntry
{
entryTag = tagNumber,
entryFormat = dataFormat,
entryNoComponents = fromIntegral $ toInteger numComponents,
entryContents = value
}
getExifTag :: TagLocation -> Word16 -> ExifTag
getExifTag l v = fromMaybe (ExifTag l Nothing v show) $ 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 = liftM (ExifNumberList . fmap fromIntegral)
$ count components (decoder byteAlign)
unsignedByteValueHandler = ValueHandler
{
dataTypeId = 1,
dataLength = 1,
readSingle = \_ -> liftM (ExifNumber . fromIntegral) getWord8,
readMany = readNumberList $ const getWord8
}
asciiStringValueHandler = ValueHandler
{
dataTypeId = 2,
dataLength = 1,
readSingle = \ba -> readMany asciiStringValueHandler ba 1,
readMany = \_ components -> liftM (ExifText . Char8.unpack) (getByteString (components1))
}
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 <- liftM fromIntegral $ getWord32 byteAlign
denominator <- liftM fromIntegral $ getWord32 byteAlign
return $ c numerator denominator
unsignedRationalValueHandler = ValueHandler
{
dataTypeId = 5,
dataLength = 8,
readSingle = readRationalContents ExifRational,
readMany = \byteAlign components -> liftM ExifRationalList $ count components (readRationalContents (,) byteAlign)
}
signedByteValueHandler = ValueHandler
{
dataTypeId = 6,
dataLength = 1,
readSingle = \_ -> liftM (ExifNumber . signedInt8ToInt) getWord8,
readMany = readNumberList (liftM signedInt8ToInt . const getWord8)
}
undefinedValueHandler = ValueHandler
{
dataTypeId = 7,
dataLength = 1,
readSingle = \ba -> readMany undefinedValueHandler ba 1,
readMany = \_ components -> liftM ExifUndefined (getByteString (components1))
}
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 <- liftM signedInt32ToInt $ getWord32 byteAlign
denominator <- liftM signedInt32ToInt $ getWord32 byteAlign
return $ c numerator denominator
signedRationalValueHandler = ValueHandler
{
dataTypeId = 10,
dataLength = 8,
readSingle = readSignedRationalContents ExifRational,
readMany = \byteAlign components -> liftM ExifRationalList $ count components (readSignedRationalContents (,) byteAlign)
}
valueHandlers :: [ValueHandler]
valueHandlers =
[
unsignedByteValueHandler,
asciiStringValueHandler,
unsignedShortValueHandler,
unsignedLongValueHandler,
unsignedRationalValueHandler,
signedByteValueHandler,
signedShortValueHandler,
signedLongValueHandler,
signedRationalValueHandler,
undefinedValueHandler
]
decodeEntry :: ByteAlign -> Int -> TagLocation -> IfEntry -> Get (ExifTag, ExifValue)
decodeEntry byteAlign tiffHeaderStart location entry = do
let exifTag = getExifTag location $ entryTag entry
let contentsInt = fromIntegral $ toInteger $ entryContents entry
tagValue <- case getHandler $ entryFormat entry of
Just handler -> decodeEntryWithHandler byteAlign tiffHeaderStart handler entry
Nothing -> return $ ExifUnknown (entryFormat entry) (entryNoComponents entry) contentsInt
return (exifTag, tagValue)
getHandler :: Word16 -> Maybe ValueHandler
getHandler typeId = find ((==typeId) . dataTypeId) valueHandlers
decodeEntryWithHandler :: ByteAlign -> Int -> ValueHandler -> IfEntry -> Get ExifValue
decodeEntryWithHandler byteAlign tiffHeaderStart handler entry =
if dataLength handler * entryNoComponents entry <= 4
then do
let inlineBs = runPut $ putWord32 byteAlign $ entryContents entry
return $ parseInline byteAlign handler entry inlineBs
else parseOffset byteAlign tiffHeaderStart handler entry
parseInline :: ByteAlign -> ValueHandler -> IfEntry -> B.ByteString -> ExifValue
parseInline byteAlign handler entry bytestring =
fromJust $ runMaybeGet getter bytestring
where
getter = case entryNoComponents entry of
1 -> readSingle handler byteAlign
_ -> readMany handler byteAlign $ entryNoComponents entry
parseOffset :: ByteAlign -> Int -> ValueHandler -> IfEntry -> Get ExifValue
parseOffset byteAlign tiffHeaderStart handler entry = do
let contentsInt = fromIntegral $ toInteger $ entryContents entry
curPos <- liftM fromIntegral bytesRead
skip $ contentsInt + tiffHeaderStart curPos
bytestring <- getLazyByteString (fromIntegral $ entryNoComponents entry * dataLength handler)
return $ parseInline byteAlign handler entry 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)
runMaybeGet :: Get a -> B.ByteString -> Maybe a
runMaybeGet get bs = case runGetOrFail get bs of
Left _ -> Nothing
Right (_,_,x) -> Just x
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 $ realToFrac second)
where
readDigit x = liftM read $ count x getDigit
count :: Int -> Get a -> Get [a]
count n p | n <= 0 = return []
| otherwise = replicateM n p
getDateTimeOriginal :: Map ExifTag ExifValue -> Maybe LocalTime
getDateTimeOriginal exifData = Map.lookup dateTimeOriginal exifData >>= readExifDateTime . show
getCharWhere :: (Char->Bool) -> Get Char
getCharWhere wher = do
char <- liftM (chr . fromIntegral) getWord8
if wher char
then return char
else fail "no parse"
getDigit :: Get Char
getDigit = getCharWhere isDigit
getCharValue :: Char -> Get Char
getCharValue char = getCharWhere (==char)
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 = do
flashVal <- Map.lookup flash exifData
case flashVal of
ExifNumber n -> Just $ n .&. 1 /= 0
_ -> Nothing