{-# LANGUAGE
- UnicodeSyntax
+ BangPatterns
+ , UnboxedTuples
+ , UnicodeSyntax
#-}
--- | Data types for WavPack codec.
+-- | WavPack blocks
module Codec.Audio.WavPack.Block
- ( BlockHeader(..)
+ ( Block(..)
+ , BlockHeader(..)
, BlockFlags(..)
- , findNextHeader
+ , readBlocks
)
where
+import Codec.Audio.WavPack.Metadata
import Data.Binary
import Data.Binary.BitPut (putBit, putNBits, runBitPut)
import Data.Binary.Get
import Data.Binary.Put
-import qualified Data.Binary.Strict.BitGet as BG
import Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet)
+import qualified Data.Binary.Strict.BitGet as BG
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
+ }
+
+-- Be aware; the Get monad is like a strict State monad so the entire
+-- sub-blocks are parsed at once. This might not be what you want
+-- (like me).
+getSubBlocks ∷ Integral n ⇒ n → Get [SubBlock]
+getSubBlocks 0 = return $! []
+getSubBlocks !blockSize
+ = do before ← bytesRead
+ meta ← get
+ after ← bytesRead
+ rest ← getSubBlocks $ blockSize - fromIntegral (after - before)
+ return (meta : rest)
+
+-- The lazy version.
+getSubBlocksLazily ∷ Integral n
+ ⇒ L.ByteString
+ → n
+ → (# [SubBlock], L.ByteString #)
+getSubBlocksLazily src 0 = (# [], src #)
+getSubBlocksLazily src !blockSize
+ = let (sub, src', consumed)
+ = runGetState get src 0
+ (# subs, src'' #)
+ = getSubBlocksLazily src' $
+ blockSize - fromIntegral consumed
+ in
+ (# sub : subs, src'' #)
+
-- | The preamble to every block in both the .wv and .wvc files.
data BlockHeader
= BlockHeader {
blockSamples ← getWord32le
flags ← get
crc ← getWord32le
- return BlockHeader {
+ return $! BlockHeader {
bhSize = size + 8 - 32
, bhVersion = version
, bhTrackNo = trackNo
-- | maximum magnitude of decoded data (number of bits integers
-- require minus 1)
, bfMaxMagnitude ∷ !Word8
- -- | sampling rate (0x1111 = unknown/custom) (THINKME)
- , bfSamplingRate ∷ !(Maybe Int)
+ -- | sampling rate ('Nothing' = unknown/custom)
+ , bfSamplingRate ∷ !(S.Maybe Int)
-- | 'True' = use IIR for negative hybrid noise shaping
, bfIIRShaping ∷ !Bool
-- | 'True' = false stereo (data is mono but output is stereo)
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 $ bfFinalBlock 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
-findNextHeader ∷ L.ByteString → (Maybe BlockHeader, L.ByteString)
-findNextHeader src
+-- | Read WavPack blocks in a given stream lazily.
+readBlocks ∷ L.ByteString → [Block]
+readBlocks src
+ = case findNextBlock src of
+ (# S.Just block, src' #)
+ → block : readBlocks src'
+ (# S.Nothing, _ #)
+ → []
+
+findNextBlock ∷ L.ByteString
+ → (# S.Maybe Block, L.ByteString #)
+findNextBlock src
= case L.uncons src of
Nothing
- → (Nothing, L.empty)
-
- Just (119, src') -- 'w'
- → let (header, rest) = L.splitAt 32 src
- in
- case L.length header ≡ 32 of
- False
- → (Nothing, L.empty)
+ → (# S.Nothing, L.empty #)
- 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'
+ 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 getSubBlocksLazily rest $ bhSize bh 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
projects / wavpack.git / blobdiff