From: PHO Date: Thu, 6 Jan 2011 15:09:38 +0000 (+0900) Subject: findNextBlock X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=9128d47e1f753b82477535a1116b3a4f416243fc;p=wavpack.git findNextBlock --- diff --git a/Codec/Audio/WavPack/Block.hs b/Codec/Audio/WavPack/Block.hs index fe32381..8b532ad 100644 --- a/Codec/Audio/WavPack/Block.hs +++ b/Codec/Audio/WavPack/Block.hs @@ -1,14 +1,18 @@ {-# LANGUAGE - UnicodeSyntax + BangPatterns + , UnboxedTuples + , UnicodeSyntax #-} -- | WavPack blocks module Codec.Audio.WavPack.Block - ( BlockHeader(..) + ( Block(..) + , BlockHeader(..) , BlockFlags(..) - , findNextHeader + , findNextBlock ) where +import Codec.Audio.WavPack.Metadata import Data.Binary import Data.Binary.BitPut (putBit, putNBits, runBitPut) import Data.Binary.Get @@ -17,8 +21,38 @@ import qualified Data.Binary.Strict.BitGet as BG import Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.Strict as S import Prelude.Unicode +-- | The WavPack block. +data Block + = Block { + blockHeader ∷ !BlockHeader + , blockMetadata ∷ [SubBlock] + } + deriving (Show, Eq) + +instance Binary Block where + put b + = do put $ blockHeader b + mapM_ put $ blockMetadata b + + get = do header ← get + subs ← getSubBlocks (bhSize header) + return $! Block { + blockHeader = header + , blockMetadata = subs + } + +getSubBlocks ∷ Word32 → Get [SubBlock] +getSubBlocks 0 = return [] +getSubBlocks !blockSize + = do before ← bytesRead + meta ← get + after ← bytesRead + rest ← getSubBlocks $ blockSize - fromIntegral (after - before) + return (meta : rest) + -- | The preamble to every block in both the .wv and .wvc files. data BlockHeader = BlockHeader { @@ -72,7 +106,7 @@ instance Binary BlockHeader where blockSamples ← getWord32le flags ← get crc ← getWord32le - return BlockHeader { + return $! BlockHeader { bhSize = size + 8 - 32 , bhVersion = version , bhTrackNo = trackNo @@ -121,7 +155,7 @@ data BlockFlags -- require minus 1) , bfMaxMagnitude ∷ !Word8 -- | sampling rate ('Nothing' = unknown/custom) - , bfSamplingRate ∷ !(Maybe Int) + , bfSamplingRate ∷ !(S.Maybe Int) -- | 'True' = use IIR for negative hybrid noise shaping , bfIIRShaping ∷ !Bool -- | 'True' = false stereo (data is mono but output is stereo) @@ -131,134 +165,167 @@ data BlockFlags instance Binary BlockFlags where put bf - = let bs = runBitPut $ - do putBit False -- reserved - putBit $ bfFalseStereo bf - putBit $ bfIIRShaping bf - putNBits 2 (0 ∷ Word8) -- reserved - putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf - putNBits 5 $ bfMaxMagnitude bf - putNBits 5 $ bfLeftShift bf - putBit $ bfFinalBlock bf - putBit $ bfInitialBlock bf - putBit $ bfHybridBalance bf - putBit $ bfHybridBitrate bf - putBit $ bfExtendedInt bf - putBit $ bfFloatData bf - putBit $ bfHybridShape bf - putBit $ bfCrossDecorr bf - putBit $ bfJointStereo bf - putBit $ bfHybrid bf - putBit $ bfMono bf - putNBits 2 $ bfBytesPerSample bf - 1 + = let !bs = runBitPut $ + do putBit False -- reserved + putBit $ bfFalseStereo bf + putBit $ bfIIRShaping bf + putNBits 2 (0 ∷ Word8) -- reserved + putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf + putNBits 5 $ bfMaxMagnitude bf + putNBits 5 $ bfLeftShift bf + putBit $ bfFinalBlock bf + putBit $ bfInitialBlock bf + putBit $ bfHybridBalance bf + putBit $ bfHybridBitrate bf + putBit $ bfExtendedInt bf + putBit $ bfFloatData bf + putBit $ bfHybridShape bf + putBit $ bfCrossDecorr bf + putBit $ bfJointStereo bf + putBit $ bfHybrid bf + putBit $ bfMono bf + putNBits 2 $! bfBytesPerSample bf - 1 in putLazyByteString (L.reverse bs) get = do bs ← getBytes 4 - let Right bf - = runBitGet (S.reverse bs) $ - do BG.skip 1 -- reserved - falseStereo ← getBit - iirShaping ← getBit - BG.skip 2 -- reserved - samplingRate ← getAsWord8 4 - maxMagnitude ← getAsWord8 5 - leftShift ← getAsWord8 5 - finalBlock ← getBit - initialBlock ← getBit - hybridBalance ← getBit - hybridBitrate ← getBit - extendedInt ← getBit - floatData ← getBit - hybridShape ← getBit - crossDecorr ← getBit - jointStereo ← getBit - hybrid ← getBit - mono ← getBit - bytesPerSample ← getAsWord8 2 - return BlockFlags { - bfBytesPerSample = bytesPerSample + 1 - , bfMono = mono - , bfHybrid = hybrid - , bfJointStereo = jointStereo - , bfCrossDecorr = crossDecorr - , bfHybridShape = hybridShape - , bfFloatData = floatData - , bfExtendedInt = extendedInt - , bfHybridBitrate = hybridBitrate - , bfHybridBalance = hybridBalance - , bfInitialBlock = initialBlock - , bfFinalBlock = finalBlock - , bfLeftShift = leftShift - , bfMaxMagnitude = maxMagnitude - , bfSamplingRate = decodeSamplingRate samplingRate - , bfIIRShaping = iirShaping - , bfFalseStereo = falseStereo - } - return bf + let !r = runBitGet (S.reverse bs) $ + do BG.skip 1 -- reserved + falseStereo ← getBit + iirShaping ← getBit + BG.skip 2 -- reserved + samplingRate ← getAsWord8 4 + maxMagnitude ← getAsWord8 5 + leftShift ← getAsWord8 5 + finalBlock ← getBit + initialBlock ← getBit + hybridBalance ← getBit + hybridBitrate ← getBit + extendedInt ← getBit + floatData ← getBit + hybridShape ← getBit + crossDecorr ← getBit + jointStereo ← getBit + hybrid ← getBit + mono ← getBit + bytesPerSample ← getAsWord8 2 + return $! BlockFlags { + bfBytesPerSample = bytesPerSample + 1 + , bfMono = mono + , bfHybrid = hybrid + , bfJointStereo = jointStereo + , bfCrossDecorr = crossDecorr + , bfHybridShape = hybridShape + , bfFloatData = floatData + , bfExtendedInt = extendedInt + , bfHybridBitrate = hybridBitrate + , bfHybridBalance = hybridBalance + , bfInitialBlock = initialBlock + , bfFinalBlock = finalBlock + , bfLeftShift = leftShift + , bfMaxMagnitude = maxMagnitude + , bfSamplingRate = decodeSamplingRate samplingRate + , bfIIRShaping = iirShaping + , bfFalseStereo = falseStereo + } + case r of + Left err → fail err + Right bf → return $! bf -encodeSamplingRate ∷ Maybe Int → Word8 -encodeSamplingRate (Just 6000) = 0x00 -encodeSamplingRate (Just 8000) = 0x01 -encodeSamplingRate (Just 9600) = 0x02 -encodeSamplingRate (Just 11025) = 0x03 -encodeSamplingRate (Just 12000) = 0x04 -encodeSamplingRate (Just 16000) = 0x05 -encodeSamplingRate (Just 22050) = 0x06 -encodeSamplingRate (Just 24000) = 0x07 -encodeSamplingRate (Just 32000) = 0x08 -encodeSamplingRate (Just 44100) = 0x09 -encodeSamplingRate (Just 48000) = 0x0A -encodeSamplingRate (Just 64000) = 0x0B -encodeSamplingRate (Just 88200) = 0x0C -encodeSamplingRate (Just 96000) = 0x0D -encodeSamplingRate (Just 192000) = 0x0E -encodeSamplingRate _ = 0x0F +encodeSamplingRate ∷ S.Maybe Int → Word8 +encodeSamplingRate (S.Just 6000) = 0x00 +encodeSamplingRate (S.Just 8000) = 0x01 +encodeSamplingRate (S.Just 9600) = 0x02 +encodeSamplingRate (S.Just 11025) = 0x03 +encodeSamplingRate (S.Just 12000) = 0x04 +encodeSamplingRate (S.Just 16000) = 0x05 +encodeSamplingRate (S.Just 22050) = 0x06 +encodeSamplingRate (S.Just 24000) = 0x07 +encodeSamplingRate (S.Just 32000) = 0x08 +encodeSamplingRate (S.Just 44100) = 0x09 +encodeSamplingRate (S.Just 48000) = 0x0A +encodeSamplingRate (S.Just 64000) = 0x0B +encodeSamplingRate (S.Just 88200) = 0x0C +encodeSamplingRate (S.Just 96000) = 0x0D +encodeSamplingRate (S.Just 192000) = 0x0E +encodeSamplingRate _ = 0x0F -decodeSamplingRate ∷ Word8 → Maybe Int -decodeSamplingRate 0x00 = Just 6000 -decodeSamplingRate 0x01 = Just 8000 -decodeSamplingRate 0x02 = Just 9600 -decodeSamplingRate 0x03 = Just 11025 -decodeSamplingRate 0x04 = Just 12000 -decodeSamplingRate 0x05 = Just 16000 -decodeSamplingRate 0x06 = Just 22025 -decodeSamplingRate 0x07 = Just 24000 -decodeSamplingRate 0x08 = Just 32000 -decodeSamplingRate 0x09 = Just 44100 -decodeSamplingRate 0x0A = Just 48000 -decodeSamplingRate 0x0B = Just 64000 -decodeSamplingRate 0x0C = Just 88200 -decodeSamplingRate 0x0D = Just 96000 -decodeSamplingRate 0x0E = Just 192000 -decodeSamplingRate _ = Nothing +decodeSamplingRate ∷ Word8 → S.Maybe Int +decodeSamplingRate 0x00 = S.Just 6000 +decodeSamplingRate 0x01 = S.Just 8000 +decodeSamplingRate 0x02 = S.Just 9600 +decodeSamplingRate 0x03 = S.Just 11025 +decodeSamplingRate 0x04 = S.Just 12000 +decodeSamplingRate 0x05 = S.Just 16000 +decodeSamplingRate 0x06 = S.Just 22025 +decodeSamplingRate 0x07 = S.Just 24000 +decodeSamplingRate 0x08 = S.Just 32000 +decodeSamplingRate 0x09 = S.Just 44100 +decodeSamplingRate 0x0A = S.Just 48000 +decodeSamplingRate 0x0B = S.Just 64000 +decodeSamplingRate 0x0C = S.Just 88200 +decodeSamplingRate 0x0D = S.Just 96000 +decodeSamplingRate 0x0E = S.Just 192000 +decodeSamplingRate _ = S.Nothing --- | Find a WavPack header in a given stream. Returns 'Nothing' if no --- headers are found. -findNextHeader ∷ L.ByteString -- ^ the input - → Maybe (BlockHeader, L.ByteString) -- ^ a header and the rest of input -findNextHeader src +-- | Find a WavPack block in a given stream. Returns 'S.Nothing' if no +-- blocks are found. +findNextBlock ∷ L.ByteString -- ^ the input + → (# S.Maybe Block, L.ByteString #) -- ^ the rest of input +findNextBlock src = case L.uncons src of Nothing - → Nothing - Just (119, src') -- 'w' - → let (header, rest) = L.splitAt 32 src - in - case L.length header ≡ 32 of - False - → Nothing - True - → let Just (magicW, header' ) = L.uncons header - Just (magicV, header'' ) = L.uncons header' - Just (magicP, header''') = L.uncons header'' - magicK = L.head header''' - in - if magicW ≡ 119 ∧ magicV ≡ 118 ∧ magicP ≡ 112 ∧ magicK ≡ 107 then - -- Found the magic 'wvpk'. - let bh = runGet get header - in - Just (bh, rest) - else - findNextHeader src' + → (# S.Nothing, L.empty #) + + Just (119, _) -- 'w' + → tryGetBlock src + Just (_, src') - → findNextHeader src' + → findNextBlock src' + +tryGetBlock ∷ L.ByteString → (# S.Maybe Block, L.ByteString #) +tryGetBlock src + = case L.splitAt 32 src of + (header, rest) + → case L.length header ≡ 32 of + True + → case L.take 4 header ≡ headerMagic of + True + -- Found the magic "wvpk". Let's parse + -- the header and see if it's really a + -- header we can accept. + → case runGet get header of + bh → if isGoodHeader bh then + case runGetState (getSubBlocks $ bhSize bh) rest 0 of + (subs, rest', _) + → let !blk = Block { + blockHeader = bh + , blockMetadata = subs + } + in + (# S.Just blk, rest' #) + else + findNextBlock $ L.tail src + False + → findNextBlock $ L.tail src + False + → (# S.Nothing, L.empty #) + +headerMagic ∷ L.ByteString +headerMagic = L.pack [119, 118, 112, 107] -- "wvpk" + +isGoodHeader ∷ BlockHeader → Bool +isGoodHeader bh + -- Rule #1: bhSize + 32 - 8 ≡ 0 (mod 2) + | odd $ bhSize bh = False + -- Rule #2: bhSize + 32 - 8 ≤ 0x00100000 + | bhSize bh + 32 - 8 > 0x100000 = False + -- Rule #3: bhSize + 32 - 8 > 24 + | bhSize bh + 32 - 8 ≤ 24 = False + -- Rule #4: 0x402 ≤ bhVersion ≤ 0x410 + | bhVersion bh < 0x402 = False + | bhVersion bh > 0x410 = False + -- Rule #5: bhBlockSamples < 0x00030000 + | bhBlockSamples bh ≥ 0x30000 = False + -- Now it passed all the tests... + | otherwise = True diff --git a/Codec/Audio/WavPack/Metadata.hs b/Codec/Audio/WavPack/Metadata.hs index 35864b1..77901f4 100644 --- a/Codec/Audio/WavPack/Metadata.hs +++ b/Codec/Audio/WavPack/Metadata.hs @@ -26,7 +26,8 @@ class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where -- | Get the metadata ID without odd-size bit nor large-block bit -- (mandatory). metaID ∷ α → Word8 - -- | Get the size of metadata (optional). + -- | Get the size of metadata, excluding the metadata header + -- (optional). metaSize ∷ α → Word32 metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put -- | Cast a 'SubBlock' to this type of metadata (optional). @@ -49,18 +50,19 @@ instance Metadata SubBlock where instance Binary SubBlock where put (SubBlock a) = let size = metaSize a - oddBit = if odd size then 0x40 else 0 - largeBit = if size > 255 then 0x80 else 0 + size' = size + 1 + oddBit = if odd size then 0x40 else 0 + largeBit = if size > 0x1FE then 0x80 else 0 idWord = metaID a .|. oddBit .|. largeBit in do putWord8 idWord - if size > 255 then + if size > 0x1FE then -- Don't forget about the endianness. - do putWord8 $ fromIntegral $ (size `shiftR` 1) .&. 0xFF - putWord8 $ fromIntegral $ (size `shiftR` 9) .&. 0xFF - putWord8 $ fromIntegral $ (size `shiftR` 17) .&. 0xFF + do putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF + putWord8 $ fromIntegral $ (size' `shiftR` 9) .&. 0xFF + putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF else - putWord8 $ fromIntegral $ (size `shiftR` 1) .&. 0xFF + putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF put a when (odd size) $ putWord8 0 @@ -118,7 +120,8 @@ instance Binary Dummy where -- | Unknown but optional metadata found in the WavPack block. data Unknown = Unknown { - -- | The ID of this unknown metadata. + -- | The ID of this unknown metadata without odd-size bit nor + -- large-block bit. unkID ∷ Word8 -- | Raw data; must be less than 2^25 bytes long. , unkData ∷ L.ByteString diff --git a/examples/WvInfo.hs b/examples/WvInfo.hs index 4c5cf88..8b1f5b4 100644 --- a/examples/WvInfo.hs +++ b/examples/WvInfo.hs @@ -1,9 +1,11 @@ {-# LANGUAGE - UnicodeSyntax + UnboxedTuples + , UnicodeSyntax #-} module Main where import Codec.Audio.WavPack.Block import qualified Data.ByteString.Lazy as L +import qualified Data.Strict as S import System.Environment main ∷ IO () @@ -13,8 +15,8 @@ main = do [wvFile] ← getArgs showWvInfo ∷ L.ByteString → IO () showWvInfo stream - = case findNextHeader stream of - Just (bh, _) - → print bh - Nothing + = case findNextBlock stream of + (# S.Just block, _ #) + → print block + (# S.Nothing , _ #) → fail "Can't find any WavPack block headers." diff --git a/wavpack.cabal b/wavpack.cabal index bc30b77..740e60a 100644 --- a/wavpack.cabal +++ b/wavpack.cabal @@ -30,7 +30,8 @@ Library base-unicode-symbols == 0.2.*, binary == 0.5.*, binary-strict == 0.4.*, - bytestring == 0.9.* + bytestring == 0.9.*, + strict == 0.3.* Exposed-Modules: Codec.Audio.WavPack