module Data.Riff.Parse
( withRiffFile
, parseRiffData
) where
import Data.Riff.RiffData
import Data.Riff.InternalUtil
import Control.Monad (when, replicateM)
import Control.Monad.Trans.Either (EitherT(..), left, right)
import Control.Monad.Trans.Class
import Data.Binary.Get
import qualified Data.ByteString.Lazy as BL
import Data.Char (chr)
import Data.Word (Word8)
import GHC.IO.IOMode (IOMode(..))
import System.IO (withBinaryFile)
withRiffFile :: FilePath
-> (Either ParseError RiffFile -> IO ())
-> IO ()
withRiffFile filePath action = withBinaryFile filePath ReadMode $ \h -> do
riffData <- fmap parseRiffData (BL.hGetContents h)
action riffData
parseRiffData :: BL.ByteString
-> Either ParseError RiffFile
parseRiffData input =
case runGetOrFail (runEitherT getRiffStart) input of
Left (_, offset, error) -> Left (offset, error)
Right (_, _, result) -> result
data ParseContext = ParseContext
{ getSize :: Get RiffChunkSize
}
getRiffStart :: EitherT ParseError Get RiffFile
getRiffStart = do
id <- lift getIdentifier
(context, fileType) <- case id of
"RIFF" -> right (leContext, RIFF)
"RIFX" -> right (beContext, RIFX)
_ -> do
read <- lift bytesRead
left (read, "RIFF file not allowed to start with chunk id: '" ++ id ++ "'. Must start with either RIFF or RIFX")
size <- lift . getSize $ context
riffType <- lift getIdentifier
contents <- parseChunkList context (size 4)
return RiffFile
{ riffFileType = fileType
, riffFileFormatType = riffType
, riffFileChildren = contents
}
where
leContext = ParseContext getWord32le
beContext = ParseContext getWord32be
parseChunkList :: ParseContext -> RiffChunkSize -> EitherT ParseError Get [RiffChunk]
parseChunkList _ 0 = return []
parseChunkList context totalSize = do
(nextChunk, dataSize) <- getRiffChunk context
let chunkSize = 8 + padToWord dataSize
if totalSize <= chunkSize
then return [nextChunk]
else do
following <- parseChunkList context (totalSize chunkSize)
return $ nextChunk : following
getRiffChunk :: ParseContext -> EitherT ParseError Get (RiffChunk, RiffChunkSize)
getRiffChunk context = do
id <- lift getIdentifier
size <- lift . getSize $ context
if id == "LIST"
then do
guardListSize id size
formType <- lift getIdentifier
children <- parseChunkList context (size 4)
lift $ skipToWordBoundary size
return (RiffChunkParent
{ riffFormTypeInfo = formType
, riffChunkChildren = children
}, size)
else do
riffData <- lift $ getLazyByteString (fromIntegral size)
lift $ skipToWordBoundary size
return (RiffChunkChild
{ riffChunkId = id
, riffData = riffData
}, size)
where
guardListSize id size = when (size < 4) $ do
read <- lift bytesRead
left (read, message id size)
where
message id size =
"List Chunk Id '" ++ id
++ "' had chunk size " ++ show size
++ " which is less than 4 and invalid."
skipToWordBoundary :: RiffChunkSize -> Get ()
skipToWordBoundary size = do
empty <- isEmpty
when (not empty && size `mod` 2 == 1) $ skip 1
getNWords :: Int -> Get [Word8]
getNWords n = replicateM n getWord8
getNChars :: Int -> Get String
getNChars = fmap (fmap byteToChar) . getNWords
byteToChar :: Word8 -> Char
byteToChar = chr . fromIntegral
getIdentifier = getNChars 4