module Support.CFF(
ChunkType(),
FileType(),
FileOffset(),
ChunkLength(),
chunkType,
isCritical,
isPrivate,
isSafeToCopy,
readCFFHeader,
readCFFInfo,
readCFF,
bsCFF,
lbsCFF,
mkCFFfile,
readChunk,
lazyWriteCFF,
writeCFF
)where
import Control.Monad
import Data.Bits
import Data.Char
import Data.Word
import System.IO
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
type FileOffset = Word
type ChunkLength = Word
type FileType = ChunkType
newtype ChunkType = ChunkType Word32
deriving(Eq,Ord)
instance Show ChunkType where
showsPrec _ (ChunkType w) xs = b 3:b 2:b 1:b 0:xs where
b n = chr $ fromIntegral ((w `shiftR` (8 * n)) .&. 0xFF)
instance Read ChunkType where
readsPrec _ (b1:b2:b3:b4:xs) = [(chunkType [b1,b2,b3,b4],xs)]
readsPrec _ _ = []
chunkType :: String -> ChunkType
chunkType [b1,b2,b3,b4] = bytesToChunkType (fi b1) (fi b2) (fi b3) (fi b4) where
fi = fromIntegral . ord
chunkType [b1,b2,b3] = chunkType [b1,b2,b3,' ']
chunkType _ = error "chunkType: not a chunk."
isCritical :: ChunkType -> Bool
isCritical (ChunkType w) = w .&. 0x20000000 == 0
isPrivate :: ChunkType -> Bool
isPrivate (ChunkType w) = w .&. 0x00200000 == 0
isSafeToCopy :: ChunkType -> Bool
isSafeToCopy (ChunkType w) = w .&. 0x00000020 == 0
lbsCFF :: Monad m => LBS.ByteString -> m (FileType,[(ChunkType,LBS.ByteString)])
lbsCFF bs = ans bs where
ans bs' = do
let checkByte n b = do
unless ((bs `LBS.index` n) == b) $ fail "bsCFF: invalid chunked file"
bs = LBS.take 8 bs'
when (LBS.length bs < 8) $ fail "bsCFF: chunked file is too short"
checkByte 0 0x89
checkByte 4 0x0d
let b1 = bs `LBS.index` 1
b2 = bs `LBS.index` 2
b3 = bs `LBS.index` 3
checkByte 5 0x0a
checkByte 6 0x1a
checkByte 7 0x0a
let header = bytesToChunkType b1 b2 b3 (fromIntegral $ ord ' ')
return (header,readRest (LBS.drop 8 bs))
bsWord32 :: LBS.ByteString -> Word32
bsWord32 bs = w where
b1 = bs `LBS.index` 0
b2 = bs `LBS.index` 1
b3 = bs `LBS.index` 2
b4 = bs `LBS.index` 3
ChunkType w = bytesToChunkType b1 b2 b3 b4
readRest bs = f bs where
f bs | LBS.null bs = []
f bs = (ct,bdata):f (LBS.drop 4 brest) where
len = bsWord32 bs
ct = ChunkType $ bsWord32 (LBS.drop 4 bs)
(bdata,brest) = LBS.splitAt (fromIntegral len) (LBS.drop 8 bs)
bsCFF :: Monad m => BS.ByteString -> m (FileType,[(ChunkType,BS.ByteString)])
bsCFF bs = ans bs where
ans bs = do
let checkByte n b = do
unless ((bs `BS.index` n) == b) $ fail "bsCFF: invalid chunked file"
when (BS.length bs < 8) $ fail "bsCFF: chunked file is too short"
checkByte 0 0x89
checkByte 4 0x0d
let b1 = bs `BS.index` 1
b2 = bs `BS.index` 2
b3 = bs `BS.index` 3
checkByte 5 0x0a
checkByte 6 0x1a
checkByte 7 0x0a
let header = bytesToChunkType b1 b2 b3 (fromIntegral $ ord ' ')
return (header,readRest (BS.drop 8 bs))
bsWord32 :: BS.ByteString -> Word32
bsWord32 bs = w where
b1 = bs `BS.index` 0
b2 = bs `BS.index` 1
b3 = bs `BS.index` 2
b4 = bs `BS.index` 3
ChunkType w = bytesToChunkType b1 b2 b3 b4
readRest bs = f bs where
f bs | BS.null bs = []
f bs = (ct,bdata):f (BS.drop 4 brest) where
len = bsWord32 bs
ct = ChunkType $ bsWord32 (BS.drop 4 bs)
(bdata,brest) = BS.splitAt (fromIntegral len) (BS.drop 8 bs)
mkCFFHeader :: FileType -> BS.ByteString
mkCFFHeader (ChunkType ft) = BS.pack [0x89,b1,b2,b3,0x0d,0x0a,0x1a,0x0a] where
(b1,b2,b3,_) = word32ToBytes ft
readCFFHeader :: Handle -> IO ChunkType
readCFFHeader h = do
let checkByte b = do
z <- getByte h
unless (z == b) $ fail "readCFFInfo: invalid chunked file"
checkByte 0x89
b1 <- getByte h
b2 <- getByte h
b3 <- getByte h
checkByte 0x0d
checkByte 0x0a
checkByte 0x1a
checkByte 0x0a
return $ bytesToChunkType b1 b2 b3 (fromIntegral $ ord ' ')
writeCFFHeader :: Handle -> FileType -> IO ()
writeCFFHeader h ft = BS.hPut h (mkCFFHeader ft)
readCFFInfo :: Handle -> IO (ChunkType,[(ChunkType,FileOffset,ChunkLength)])
readCFFInfo h = do
cffType <- readCFFHeader h
let readChunk !fo = do
b <- hIsEOF h
if b then return [] else do
len <- readWord32 h
ct <- readChunkType h
hSeek h RelativeSeek (fromIntegral len)
_csum <- readWord32 h
xs <- readChunk (fo + fromIntegral len + 12)
return ((ct,fo + 8,fromIntegral len):xs)
xs <- readChunk (8::FileOffset)
return (cffType,xs)
readCFF :: Handle -> IO (ChunkType,[(ChunkType,BS.ByteString)])
readCFF h = do
cffType <- readCFFHeader h
let readChunk = do
b <- hIsEOF h
if b then return [] else do
len <- readWord32 h
ct <- readChunkType h
bs <- BS.hGet h (fromIntegral len)
_csum <- readWord32 h
xs <- readChunk
return ((ct,bs):xs)
xs <- readChunk
return (cffType,xs)
readChunk :: Handle -> ChunkType -> ChunkType -> IO BS.ByteString
readChunk h eft ect = do
cffType <- readCFFHeader h
when (cffType /= eft) $ fail "readChunk: CFF file of incorrect type"
let readChunk = do
b <- hIsEOF h
if b then fail "readChunk: specified chunk was not found" else do
len <- readWord32 h
ct <- readChunkType h
if ct == ect then do BS.hGet h (fromIntegral len) else do
hSeek h RelativeSeek (fromIntegral len + 4)
readChunk
readChunk
mkCFFfile :: FileType -> [(ChunkType,LBS.ByteString)] -> LBS.ByteString
mkCFFfile ft cs = LBS.fromChunks [mkCFFHeader ft] `LBS.append` LBS.concat (concatMap f cs) where
f (ChunkType ct,bs) = [hl,bs,zero] where
(b1,b2,b3,b4) = word32ToBytes ct
(l1,l2,l3,l4) = word32ToBytes (fromIntegral $ LBS.length bs)
hl = LBS.pack [l1,l2,l3,l4,b1,b2,b3,b4]
zero :: LBS.ByteString
zero = LBS.pack [0,0,0,0]
writeCFF :: Handle -> ChunkType -> [(ChunkType,BS.ByteString)] -> IO ()
writeCFF h ft xs = do
writeCFFHeader h ft
let writeChunk (ChunkType ct,bs) = do
writeWord32 h (fromIntegral $ BS.length bs)
writeWord32 h ct
BS.hPut h bs
writeWord32 h 0
mapM_ writeChunk xs
lazyWriteCFF :: Handle -> ChunkType -> [(ChunkType,LBS.ByteString)] -> IO ()
lazyWriteCFF h ft xs = do
writeCFFHeader h ft
let writeChunk (ChunkType ct,bs) = do
writeWord32 h (fromIntegral $ LBS.length bs)
writeWord32 h ct
LBS.hPut h bs
writeWord32 h 0
mapM_ writeChunk xs
getByte :: Handle -> IO Word8
getByte h = liftM (fromIntegral . ord) (hGetChar h)
writeByte :: Handle -> Word8 -> IO ()
writeByte h b = hPutChar h (chr $ fromIntegral b)
bytesToChunkType :: Word8 -> Word8 -> Word8 -> Word8 -> ChunkType
bytesToChunkType b1 b2 b3 b4 = ChunkType $ bytesToWord32 b1 b2 b3 b4
word32ToBytes :: Word32 -> (Word8,Word8,Word8,Word8)
word32ToBytes w = (b 3,b 2,b 1,b 0) where
b n = fromIntegral ((w `shiftR` (8 * n)) .&. 0xFF)
bytesToWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
bytesToWord32 b1 b2 b3 b4 = b 3 b1 .|. b 2 b2 .|. b 1 b3 .|. b 0 b4 where
b n c = (fromIntegral c) `shiftL` (8 * n)
readChunkType :: Handle -> IO ChunkType
readChunkType h = do
w <- readWord32 h
return $ ChunkType w
readWord32 :: Handle -> IO Word32
readWord32 h = do
b1 <- getByte h
b2 <- getByte h
b3 <- getByte h
b4 <- getByte h
let ChunkType ct = bytesToChunkType b1 b2 b3 b4
return ct
writeWord32 :: Handle -> Word32 -> IO ()
writeWord32 h w = do
let (b1,b2,b3,b4) = word32ToBytes w
writeByte h b1
writeByte h b2
writeByte h b3
writeByte h b4