7 module Codec.Audio.WavPack.Block
15 import Codec.Audio.WavPack.Metadata
17 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
18 import Data.Binary.Get
19 import Data.Binary.Put
20 import qualified Data.Binary.Strict.BitGet as BG
21 import Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet)
22 import qualified Data.ByteString as S
23 import qualified Data.ByteString.Lazy as L
24 import qualified Data.Strict as S
25 import Prelude.Unicode
27 -- | The WavPack block.
30 blockHeader ∷ !BlockHeader
31 , blockMetadata ∷ [SubBlock]
35 instance Binary Block where
37 = do put $ blockHeader b
38 mapM_ put $ blockMetadata b
41 subs ← getSubBlocks (bhSize header)
44 , blockMetadata = subs
47 getSubBlocks ∷ Word32 → Get [SubBlock]
48 getSubBlocks 0 = return []
49 getSubBlocks !blockSize
50 = do before ← bytesRead
53 rest ← getSubBlocks $ blockSize - fromIntegral (after - before)
56 -- | The preamble to every block in both the .wv and .wvc files.
59 -- | size of entire block (excluding the header)
61 -- | 0x402 to 0x410 are currently valid for decode
63 -- | track number (0 if not used, like now)
65 -- | track sub-index (0 if not used, like now)
67 -- | total samples for entire file, but this is only valid if
68 -- 'bhBlockIndex' == 0 and a value of -1 indicates unknown
70 , bhTotalSamples ∷ !Word32
71 -- | index of first sample in block relative to beginning of
72 -- file (normally this would start at 0 for the first block)
73 , bhBlockIndex ∷ !Word32
74 -- | number of samples in this block (0 = no audio)
75 , bhBlockSamples ∷ !Word32
76 -- | various flags for id and decoding
77 , bhFlags ∷ !BlockFlags
78 -- | crc for actual decoded data
83 instance Binary BlockHeader where
85 = do putWord8 119 -- 'w'
89 putWord32le $ bhSize bh + 32 - 8
90 putWord16le $ bhVersion bh
91 putWord8 $ bhTrackNo bh
92 putWord8 $ bhIndexNo bh
93 putWord32le $ bhTotalSamples bh
94 putWord32le $ bhBlockIndex bh
95 putWord32le $ bhBlockSamples bh
97 putWord32le $ bhCRC bh
99 get = do skip 4 -- "wvpk"
101 version ← getWord16le
104 totalSamples ← getWord32le
105 blockIndex ← getWord32le
106 blockSamples ← getWord32le
109 return $! BlockHeader {
110 bhSize = size + 8 - 32
111 , bhVersion = version
112 , bhTrackNo = trackNo
113 , bhIndexNo = indexNo
114 , bhTotalSamples = totalSamples
115 , bhBlockIndex = blockIndex
116 , bhBlockSamples = blockSamples
121 -- | Various flags for decoding blocks
125 bfBytesPerSample ∷ !Word8
126 -- | 'False' = stereo output; 'True' = mono output
128 -- | 'False' = lossless mode; 'True' = hybrid mode
130 -- | 'False' = true stereo; 'True' = joint stereo (mid/side)
131 , bfJointStereo ∷ !Bool
132 -- | 'False' = independent channels; 'True' = cross-channel
134 , bfCrossDecorr ∷ !Bool
135 -- | 'False' = flat noise spectrum in hybrid; 'True' = hybrid
137 , bfHybridShape ∷ !Bool
138 -- | 'False' = integer data; 'True' = floating point data
139 , bfFloatData ∷ !Bool
140 -- | 'True' = extended size integers (> 24-bit); 'False' =
142 , bfExtendedInt ∷ !Bool
143 -- | 'False' = hybrid mode parameters control noise level;
144 -- 'True' = hybrid mode parameters control bitrate
145 , bfHybridBitrate ∷ !Bool
146 -- | 'True' = hybrid noise balanced between channels
147 , bfHybridBalance ∷ !Bool
148 -- | 'True' = initial block in sequence (for multichannel)
149 , bfInitialBlock ∷ !Bool
150 -- | 'True' = final block in sequence (for multichannel)
151 , bfFinalBlock ∷ !Bool
152 -- | amount of data left-shift after decode (0-31 places)
153 , bfLeftShift ∷ !Word8
154 -- | maximum magnitude of decoded data (number of bits integers
156 , bfMaxMagnitude ∷ !Word8
157 -- | sampling rate ('Nothing' = unknown/custom)
158 , bfSamplingRate ∷ !(S.Maybe Int)
159 -- | 'True' = use IIR for negative hybrid noise shaping
160 , bfIIRShaping ∷ !Bool
161 -- | 'True' = false stereo (data is mono but output is stereo)
162 , bfFalseStereo ∷ !Bool
166 instance Binary BlockFlags where
168 = let !bs = runBitPut $
169 do putBit False -- reserved
170 putBit $ bfFalseStereo bf
171 putBit $ bfIIRShaping bf
172 putNBits 2 (0 ∷ Word8) -- reserved
173 putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf
174 putNBits 5 $ bfMaxMagnitude bf
175 putNBits 5 $ bfLeftShift bf
176 putBit $ bfFinalBlock bf
177 putBit $ bfInitialBlock bf
178 putBit $ bfHybridBalance bf
179 putBit $ bfHybridBitrate bf
180 putBit $ bfExtendedInt bf
181 putBit $ bfFloatData bf
182 putBit $ bfHybridShape bf
183 putBit $ bfCrossDecorr bf
184 putBit $ bfJointStereo bf
187 putNBits 2 $! bfBytesPerSample bf - 1
189 putLazyByteString (L.reverse bs)
191 get = do bs ← getBytes 4
192 let !r = runBitGet (S.reverse bs) $
193 do BG.skip 1 -- reserved
196 BG.skip 2 -- reserved
197 samplingRate ← getAsWord8 4
198 maxMagnitude ← getAsWord8 5
199 leftShift ← getAsWord8 5
201 initialBlock ← getBit
202 hybridBalance ← getBit
203 hybridBitrate ← getBit
211 bytesPerSample ← getAsWord8 2
212 return $! BlockFlags {
213 bfBytesPerSample = bytesPerSample + 1
216 , bfJointStereo = jointStereo
217 , bfCrossDecorr = crossDecorr
218 , bfHybridShape = hybridShape
219 , bfFloatData = floatData
220 , bfExtendedInt = extendedInt
221 , bfHybridBitrate = hybridBitrate
222 , bfHybridBalance = hybridBalance
223 , bfInitialBlock = initialBlock
224 , bfFinalBlock = finalBlock
225 , bfLeftShift = leftShift
226 , bfMaxMagnitude = maxMagnitude
227 , bfSamplingRate = decodeSamplingRate samplingRate
228 , bfIIRShaping = iirShaping
229 , bfFalseStereo = falseStereo
233 Right bf → return $! bf
235 encodeSamplingRate ∷ S.Maybe Int → Word8
236 encodeSamplingRate (S.Just 6000) = 0x00
237 encodeSamplingRate (S.Just 8000) = 0x01
238 encodeSamplingRate (S.Just 9600) = 0x02
239 encodeSamplingRate (S.Just 11025) = 0x03
240 encodeSamplingRate (S.Just 12000) = 0x04
241 encodeSamplingRate (S.Just 16000) = 0x05
242 encodeSamplingRate (S.Just 22050) = 0x06
243 encodeSamplingRate (S.Just 24000) = 0x07
244 encodeSamplingRate (S.Just 32000) = 0x08
245 encodeSamplingRate (S.Just 44100) = 0x09
246 encodeSamplingRate (S.Just 48000) = 0x0A
247 encodeSamplingRate (S.Just 64000) = 0x0B
248 encodeSamplingRate (S.Just 88200) = 0x0C
249 encodeSamplingRate (S.Just 96000) = 0x0D
250 encodeSamplingRate (S.Just 192000) = 0x0E
251 encodeSamplingRate _ = 0x0F
253 decodeSamplingRate ∷ Word8 → S.Maybe Int
254 decodeSamplingRate 0x00 = S.Just 6000
255 decodeSamplingRate 0x01 = S.Just 8000
256 decodeSamplingRate 0x02 = S.Just 9600
257 decodeSamplingRate 0x03 = S.Just 11025
258 decodeSamplingRate 0x04 = S.Just 12000
259 decodeSamplingRate 0x05 = S.Just 16000
260 decodeSamplingRate 0x06 = S.Just 22025
261 decodeSamplingRate 0x07 = S.Just 24000
262 decodeSamplingRate 0x08 = S.Just 32000
263 decodeSamplingRate 0x09 = S.Just 44100
264 decodeSamplingRate 0x0A = S.Just 48000
265 decodeSamplingRate 0x0B = S.Just 64000
266 decodeSamplingRate 0x0C = S.Just 88200
267 decodeSamplingRate 0x0D = S.Just 96000
268 decodeSamplingRate 0x0E = S.Just 192000
269 decodeSamplingRate _ = S.Nothing
271 -- | Find a WavPack block in a given stream. Returns 'S.Nothing' if no
273 findNextBlock ∷ L.ByteString -- ^ the input
274 → (# S.Maybe Block, L.ByteString #) -- ^ the rest of input
276 = case L.uncons src of
278 → (# S.Nothing, L.empty #)
286 tryGetBlock ∷ L.ByteString → (# S.Maybe Block, L.ByteString #)
288 = case L.splitAt 32 src of
290 → case L.length header ≡ 32 of
292 → case L.take 4 header ≡ headerMagic of
294 -- Found the magic "wvpk". Let's parse
295 -- the header and see if it's really a
296 -- header we can accept.
297 → case runGet get header of
298 bh → if isGoodHeader bh then
299 case runGetState (getSubBlocks $ bhSize bh) rest 0 of
303 , blockMetadata = subs
306 (# S.Just blk, rest' #)
308 findNextBlock $ L.tail src
310 → findNextBlock $ L.tail src
312 → (# S.Nothing, L.empty #)
314 headerMagic ∷ L.ByteString
315 headerMagic = L.pack [119, 118, 112, 107] -- "wvpk"
317 isGoodHeader ∷ BlockHeader → Bool
319 -- Rule #1: bhSize + 32 - 8 ≡ 0 (mod 2)
320 | odd $ bhSize bh = False
321 -- Rule #2: bhSize + 32 - 8 ≤ 0x00100000
322 | bhSize bh + 32 - 8 > 0x100000 = False
323 -- Rule #3: bhSize + 32 - 8 > 24
324 | bhSize bh + 32 - 8 ≤ 24 = False
325 -- Rule #4: 0x402 ≤ bhVersion ≤ 0x410
326 | bhVersion bh < 0x402 = False
327 | bhVersion bh > 0x410 = False
328 -- Rule #5: bhBlockSamples < 0x00030000
329 | bhBlockSamples bh ≥ 0x30000 = False
330 -- Now it passed all the tests...