findNextBlock
[wavpack.git] / Codec / Audio / WavPack / Block.hs
1 {-# LANGUAGE
2     BangPatterns
3   , UnboxedTuples
4   , UnicodeSyntax
5   #-}
6 -- | WavPack blocks
7 module Codec.Audio.WavPack.Block
8     ( Block(..)
9     , BlockHeader(..)
10     , BlockFlags(..)
11
12     , findNextBlock
13     )
14     where
15 import Codec.Audio.WavPack.Metadata
16 import Data.Binary
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
26
27 -- | The WavPack block.
28 data Block
29     = Block {
30         blockHeader   ∷ !BlockHeader
31       , blockMetadata ∷ [SubBlock]
32       }
33     deriving (Show, Eq)
34
35 instance Binary Block where
36     put b
37         = do put $ blockHeader b
38              mapM_ put $ blockMetadata b
39
40     get = do header ← get
41              subs   ← getSubBlocks (bhSize header)
42              return $! Block {
43                           blockHeader   = header
44                         , blockMetadata = subs
45                         }
46
47 getSubBlocks ∷ Word32 → Get [SubBlock]
48 getSubBlocks 0  = return []
49 getSubBlocks !blockSize
50     = do before ← bytesRead
51          meta   ← get
52          after  ← bytesRead
53          rest   ← getSubBlocks $ blockSize - fromIntegral (after - before)
54          return (meta : rest)
55
56 -- | The preamble to every block in both the .wv and .wvc files.
57 data BlockHeader
58     = BlockHeader {
59       -- | size of entire block (excluding the header)
60         bhSize         ∷ !Word32
61       -- | 0x402 to 0x410 are currently valid for decode
62       , bhVersion      ∷ !Word16
63       -- | track number (0 if not used, like now)
64       , bhTrackNo      ∷ !Word8
65       -- | track sub-index (0 if not used, like now)
66       , bhIndexNo      ∷ !Word8
67       -- | total samples for entire file, but this is only valid if
68       --   'bhBlockIndex' == 0 and a value of -1 indicates unknown
69       --   length
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
79       , bhCRC          ∷ !Word32
80       }
81     deriving (Show, Eq)
82
83 instance Binary BlockHeader where
84     put bh
85         = do putWord8 119 -- 'w'
86              putWord8 118 -- 'v'
87              putWord8 112 -- 'p'
88              putWord8 107 -- 'k'
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
96              put         $ bhFlags        bh
97              putWord32le $ bhCRC          bh
98
99     get = do skip 4 -- "wvpk"
100              size         ← getWord32le
101              version      ← getWord16le
102              trackNo      ← getWord8
103              indexNo      ← getWord8
104              totalSamples ← getWord32le
105              blockIndex   ← getWord32le
106              blockSamples ← getWord32le
107              flags        ← get
108              crc          ← 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
117                             , bhFlags        = flags
118                             , bhCRC          = crc
119                             }
120
121 -- | Various flags for decoding blocks
122 data BlockFlags
123     = BlockFlags {
124       -- | 1 <= n <= 4
125         bfBytesPerSample ∷ !Word8
126       -- | 'False' = stereo output; 'True' = mono output
127       , bfMono           ∷ !Bool
128       -- | 'False' = lossless mode; 'True' = hybrid mode
129       , bfHybrid         ∷ !Bool
130       -- | 'False' = true stereo; 'True' = joint stereo (mid/side)
131       , bfJointStereo    ∷ !Bool
132       -- | 'False' = independent channels; 'True' = cross-channel
133       --   decorrelation
134       , bfCrossDecorr    ∷ !Bool
135       -- | 'False' = flat noise spectrum in hybrid; 'True' = hybrid
136       --   noise shaping
137       , bfHybridShape    ∷ !Bool
138       -- | 'False' = integer data; 'True' = floating point data
139       , bfFloatData      ∷ !Bool
140       -- | 'True' = extended size integers (> 24-bit); 'False' =
141       --   shifted integers
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
155       --   require minus 1)
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
163       }
164     deriving (Show, Eq)
165
166 instance Binary BlockFlags where
167     put bf
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
185                        putBit $ bfHybrid        bf
186                        putBit $ bfMono          bf
187                        putNBits 2 $! bfBytesPerSample bf - 1
188           in
189             putLazyByteString (L.reverse bs)
190
191     get = do bs ← getBytes 4
192              let !r = runBitGet (S.reverse bs) $
193                       do BG.skip 1 -- reserved
194                          falseStereo    ← getBit
195                          iirShaping     ← getBit
196                          BG.skip 2 -- reserved
197                          samplingRate   ← getAsWord8 4
198                          maxMagnitude   ← getAsWord8 5
199                          leftShift      ← getAsWord8 5
200                          finalBlock     ← getBit
201                          initialBlock   ← getBit
202                          hybridBalance  ← getBit
203                          hybridBitrate  ← getBit
204                          extendedInt    ← getBit
205                          floatData      ← getBit
206                          hybridShape    ← getBit
207                          crossDecorr    ← getBit
208                          jointStereo    ← getBit
209                          hybrid         ← getBit
210                          mono           ← getBit
211                          bytesPerSample ← getAsWord8 2
212                          return $! BlockFlags {
213                                       bfBytesPerSample = bytesPerSample + 1
214                                     , bfMono           = mono
215                                     , bfHybrid         = hybrid
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
230                                     }
231              case r of
232                Left err → fail err
233                Right bf → return $! bf
234
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
252
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
270
271 -- | Find a WavPack block in a given stream. Returns 'S.Nothing' if no
272 -- blocks are found.
273 findNextBlock ∷ L.ByteString -- ^ the input
274               → (# S.Maybe Block, L.ByteString #) -- ^ the rest of input
275 findNextBlock src
276     = case L.uncons src of
277         Nothing
278             → (# S.Nothing, L.empty #)
279
280         Just (119, _) -- 'w'
281             → tryGetBlock src
282
283         Just (_, src')
284             → findNextBlock src'
285
286 tryGetBlock ∷ L.ByteString → (# S.Maybe Block, L.ByteString #)
287 tryGetBlock src
288     = case L.splitAt 32 src of
289         (header, rest)
290             → case L.length header ≡ 32 of
291                  True
292                      → case L.take 4 header ≡ headerMagic of
293                           True
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
300                                                (subs, rest', _)
301                                                    → let !blk = Block {
302                                                                    blockHeader   = bh
303                                                                  , blockMetadata = subs
304                                                                  }
305                                                       in
306                                                         (# S.Just blk, rest' #)
307                                          else
308                                              findNextBlock $ L.tail src
309                           False
310                               → findNextBlock $ L.tail src
311                  False
312                      → (# S.Nothing, L.empty #)
313
314 headerMagic ∷ L.ByteString
315 headerMagic = L.pack [119, 118, 112, 107] -- "wvpk"
316
317 isGoodHeader ∷ BlockHeader → Bool
318 isGoodHeader bh
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...
331     | otherwise                     = True