ajhc-0.8.0.1: src/Support/CFF.hs
{-# OPTIONS -funbox-strict-fields -O2 #-}
{-# LANGUAGE BangPatterns #-}
-- chunked file format.
-- A generalization of the PNG format for user defined file formats.
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
-- the file's magic number is as follows:
--
-- 0x89 - high bit set, to check for 8 bit transmission errors and to avoid being treated as a text file
-- 3 bytes - identifies the particular file format. i.e. 'PNG' or 'JHC'
-- 0x0D 0x0A - DOS style line ending, to detect errors.
-- 0x1A - EOF marker, to avoid corrupting the screen when typed under dos/windows
-- 0x0A - unix EOL marker, to detect line conversion errors
-----------------------------------
-- Routines dealing with ChunkTypes
-----------------------------------
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."
-- critical if the first letter is capitalized
isCritical :: ChunkType -> Bool
isCritical (ChunkType w) = w .&. 0x20000000 == 0
-- private if the second letter is capitalized
isPrivate :: ChunkType -> Bool
isPrivate (ChunkType w) = w .&. 0x00200000 == 0
-- chunk should be copied if unrecognized by an editor
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 -- TODO verify checksum
xs <- readChunk
return ((ct,bs):xs)
xs <- readChunk
return (cffType,xs)
-- this verifies a cff is of a specific type, and reads a specific chunk only.
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 -- TODO proper checksum
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 -- TODO proper checksum
mapM_ writeChunk xs
-------------------------------------------------
-- Various routines for reading and writing bytes
-------------------------------------------------
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