module Graphics.HsExif (
ExifTag(..),
TagLocation(..),
ExifValue(..),
parseFileExif,
parseExif,
getDateTimeOriginal,
getOrientation,
ImageOrientation(..),
RotationDirection(..),
exposureTime,
fnumber,
exposureProgram,
isoSpeedRatings,
exifVersion,
dateTimeOriginal,
dateTimeDigitized,
componentConfiguration,
compressedBitsPerPixel,
shutterSpeedValue,
apertureValue,
brightnessValue,
exposureBiasValue,
maxApertureValue,
subjectDistance,
meteringMode,
lightSource,
flash,
focalLength,
makerNote,
userComment,
colorSpace,
exifImageWidth,
exifImageHeight,
relatedSoundFile,
focalPlaneXResolution,
focalPlaneYResolution,
focalPlaneResolutionUnit,
sensingMethod,
fileSource,
sceneType,
orientation,
make,
model,
software,
copyright,
) where
import Data.Binary.Get
import qualified Data.ByteString.Lazy as B
import Control.Monad (liftM, unless)
import qualified Data.ByteString.Char8 as Char8
import Data.Word
import Data.Int (Int32)
import Data.List
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Time.LocalTime
import Data.Time.Calendar
import Numeric (showHex)
data ExifValue = ExifNumber Int
| ExifText String
| ExifRational Int Int
| ExifUnknown Word16 Int
deriving Eq
instance Show ExifValue where
show (ExifNumber v) = show v
show (ExifText v) = v
show (ExifRational n d) = show n ++ "/" ++ show d
show (ExifUnknown t v) = show "Unknown exif type. Type: " ++ show t ++ " value: " ++ show v
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
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, ifdEntries) <- parseIfd byteAlign tiffHeaderStart
let exifSubIfdOffset = fromIntegral $ toInteger exifSubIfdOffsetW
bytesReadNow <- liftM fromIntegral bytesRead
skip $ (exifSubIfdOffset + tiffHeaderStart) bytesReadNow
exifSubEntries <- parseExifSubIfd byteAlign tiffHeaderStart
return $ Map.fromList $ ifdEntries ++ exifSubEntries
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, [(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 offset in the IFD")
(find (\ e -> entryTag e == 0x8769) ifdEntries)
let exifOffset = entryContents exifOffsetEntry
entries <- mapM (decodeEntry byteAlign tiffHeaderStart IFD0) ifdEntries
return (exifOffset, entries)
parseExifSubIfd :: ByteAlign -> Int -> Get [(ExifTag, ExifValue)]
parseExifSubIfd byteAlign tiffHeaderStart = do
dirEntriesCount <- liftM toInteger (getWord16 byteAlign)
ifdEntries <- mapM (\_ -> parseIfEntry byteAlign) [1..dirEntriesCount]
mapM (decodeEntry byteAlign tiffHeaderStart ExifSubIFD) ifdEntries
data IfEntry = IfEntry
{
entryTag :: !Word16,
entryFormat :: !Word16,
entryNoComponents :: !Word32,
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 = numComponents,
entryContents = value
}
data TagLocation = ExifSubIFD | IFD0
deriving (Show, Eq, Ord)
data ExifTag = ExifTag
{
tagLocation :: TagLocation,
tagDesc :: Maybe String,
tagKey :: Word16
}
deriving (Eq, Ord)
instance Show ExifTag where
show (ExifTag _ (Just d) _) = d
show (ExifTag l _ v) = "Unknown tag, location: " ++ show l
++ ", value: 0x" ++ showHex v ""
exifSubIfdTag :: String -> Word16 -> ExifTag
exifSubIfdTag d = ExifTag ExifSubIFD (Just d)
exifIfd0Tag :: String -> Word16 -> ExifTag
exifIfd0Tag d = ExifTag IFD0 (Just d)
exposureTime = exifSubIfdTag "exposureTime" 0x829a
fnumber = exifSubIfdTag "fnumber" 0x829d
exposureProgram = exifSubIfdTag "exposureProgram" 0x8822
isoSpeedRatings = exifSubIfdTag "isoSpeedRatings" 0x8827
exifVersion = exifSubIfdTag "exifVersion" 0x9000
dateTimeOriginal = exifSubIfdTag "dateTimeOriginal" 0x9003
dateTimeDigitized = exifSubIfdTag "dateTimeDigitized" 0x9004
componentConfiguration = exifSubIfdTag "componentConfiguration" 0x9101
compressedBitsPerPixel = exifSubIfdTag "compressedBitsPerPixel" 0x9102
shutterSpeedValue = exifSubIfdTag "shutterSpeedValue" 0x9201
apertureValue = exifSubIfdTag "apertureValue" 0x9202
brightnessValue = exifSubIfdTag "brightnessValue" 0x9203
exposureBiasValue = exifSubIfdTag "exposureBiasValue" 0x9204
maxApertureValue = exifSubIfdTag "maxApertureValue" 0x9205
subjectDistance = exifSubIfdTag "subjectDistance" 0x9206
meteringMode = exifSubIfdTag "meteringMode" 0x9207
lightSource = exifSubIfdTag "lightSource" 0x9208
flash = exifSubIfdTag "flash" 0x9209
focalLength = exifSubIfdTag "focalLength" 0x920a
makerNote = exifSubIfdTag "makerNote" 0x927c
userComment = exifSubIfdTag "userComment" 0x9286
colorSpace = exifSubIfdTag "colorSpace" 0xa001
exifImageWidth = exifSubIfdTag "exifImageWidth" 0xa002
exifImageHeight = exifSubIfdTag "exifImageHeight" 0xa003
relatedSoundFile = exifSubIfdTag "relatedSoundFile" 0xa004
focalPlaneXResolution = exifSubIfdTag "focalPlaneXResolution" 0xa20e
focalPlaneYResolution = exifSubIfdTag "focalPlaneYResolution" 0xa20f
focalPlaneResolutionUnit= exifSubIfdTag "focalPlaneResolutionUnit" 0xa210
sensingMethod = exifSubIfdTag "sensingMethod" 0xa217
fileSource = exifSubIfdTag "fileSource" 0xa300
sceneType = exifSubIfdTag "sceneType" 0xa301
orientation = exifIfd0Tag "orientation" 0x0112
make = exifIfd0Tag "make" 0x010f
model = exifIfd0Tag "model" 0x0110
software = exifIfd0Tag "software" 0x0131
copyright = exifIfd0Tag "copyright" 0x8298
allExifTags :: [ExifTag]
allExifTags = [exposureTime, fnumber, exposureProgram, isoSpeedRatings,
exifVersion, dateTimeOriginal, dateTimeDigitized, componentConfiguration,
compressedBitsPerPixel, shutterSpeedValue, apertureValue, brightnessValue,
exposureBiasValue, maxApertureValue, subjectDistance, meteringMode,
lightSource, flash, focalLength, makerNote, userComment, colorSpace,
exifImageWidth, exifImageHeight, relatedSoundFile, focalPlaneXResolution,
focalPlaneYResolution, focalPlaneResolutionUnit, sensingMethod, fileSource,
sceneType, orientation, make, model, software, copyright]
getExifTag :: TagLocation -> Word16 -> ExifTag
getExifTag l v = fromMaybe (ExifTag l Nothing v) $ find (isSameTag l v) allExifTags
where isSameTag l1 v1 (ExifTag l2 _ v2) = l1 == l2 && v1 == v2
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
let componentsInt = fromIntegral $ toInteger $ entryNoComponents entry
tagValue <- case entryFormat entry of
1 -> return $ ExifNumber contentsInt
2 -> do
curPos <- liftM fromIntegral bytesRead
skip $ contentsInt + tiffHeaderStart curPos
liftM (ExifText . Char8.unpack) (getByteString (componentsInt1))
3 -> return $ ExifNumber contentsInt
4 -> return $ ExifNumber contentsInt
5 -> do
curPos <- liftM fromIntegral bytesRead
skip $ contentsInt + tiffHeaderStart curPos
numerator <- liftM fromIntegral $ getWord32 byteAlign
denominator <- liftM fromIntegral $ getWord32 byteAlign
return $ ExifRational numerator denominator
6 -> return $ ExifNumber $ signedInt32ToInt $ entryContents entry
7 -> return $ ExifNumber contentsInt
8 -> return $ ExifNumber $ signedInt32ToInt $ entryContents entry
9 -> return $ ExifNumber $ signedInt32ToInt $ entryContents entry
10 -> do
curPos <- liftM fromIntegral bytesRead
skip $ contentsInt + tiffHeaderStart curPos
numerator <- liftM signedInt32ToInt (getWord32 byteAlign)
denominator <- liftM signedInt32ToInt (getWord32 byteAlign)
return $ ExifRational numerator denominator
_ -> return $ ExifUnknown (entryFormat entry) contentsInt
return (exifTag, tagValue)
signedInt32ToInt :: Word32 -> Int
signedInt32ToInt w = fromIntegral (fromIntegral w :: Int32)
getDateTimeOriginal :: Map ExifTag ExifValue -> Maybe LocalTime
getDateTimeOriginal exifData = do
dateStr <- liftM show $ Map.lookup dateTimeOriginal exifData
return $ LocalTime
(fromGregorian (read $ take 4 dateStr) (read $ take 2 . drop 5 $ dateStr) (read $ take 2 . drop 8 $ dateStr))
(TimeOfDay (read $ take 2 . drop 11 $ dateStr) (read $ take 2 . drop 14 $ dateStr) (read $ take 2 . drop 17 $ dateStr))
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
_ -> error $ show rotationVal