fix a bug in put :: BlockFlags -> Put

[wavpack.git] / Codec / Audio / WavPack / Block.hs

diff --git a/Codec/Audio/WavPack/Block.hs b/Codec/Audio/WavPack/Block.hs
index e3732eeba813f0b613537e81442447a38ffd8876..db527064654a261705ac8a2e458323ecdf138943 100644 (file)
--- a/Codec/Audio/WavPack/Block.hs
+++ b/Codec/Audio/WavPack/Block.hs
@@ -5,6 +5,8 @@
 module Codec.Audio.WavPack.Block
     ( BlockHeader(..)
     , BlockFlags(..)
+
+    , findNextHeader 
     )
     where
 import Data.Binary
@@ -15,11 +17,12 @@ 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 Prelude.Unicode
 
 -- | The preamble to every block in both the .wv and .wvc files.
 data BlockHeader
     = BlockHeader {
-      -- | size of entire block (minus 8, of course)
+      -- | size of entire block (excluding the header)
         bhSize         ∷ !Word32
       -- | 0x402 to 0x410 are currently valid for decode
       , bhVersion      ∷ !Word16
@@ -37,7 +40,7 @@ data BlockHeader
       -- | number of samples in this block (0 = no audio)
       , bhBlockSamples ∷ !Word32
       -- | various flags for id and decoding
-      , bhFlags        ∷ !BlockHeader
+      , bhFlags        ∷ !BlockFlags
       -- | crc for actual decoded data
       , bhCRC          ∷ !Word32
       }
@@ -49,7 +52,7 @@ instance Binary BlockHeader where
              putWord8 118 -- 'v'
              putWord8 112 -- 'p'
              putWord8 107 -- 'k'
-             putWord32le $ bhSize         bh
+             putWord32le $ bhSize         bh + 32 - 8
              putWord16le $ bhVersion      bh
              putWord8    $ bhTrackNo      bh
              putWord8    $ bhIndexNo      bh
@@ -70,7 +73,7 @@ instance Binary BlockHeader where
              flags        ← get
              crc          ← getWord32le
              return BlockHeader {
-                              bhSize         = size
+                              bhSize         = size + 8 - 32
                             , bhVersion      = version
                             , bhTrackNo      = trackNo
                             , bhIndexNo      = indexNo
@@ -117,8 +120,8 @@ data BlockFlags
       -- | maximum magnitude of decoded data (number of bits integers
       --   require minus 1)
       , bfMaxMagnitude   ∷ !Word8
-      -- | sampling rate (0x1111 = unknown/custom) (THINKME)
-      , bfSamplingRate   ∷ !Word8
+      -- | sampling rate ('Nothing' = unknown/custom)
+      , bfSamplingRate   ∷ !(Maybe Int)
       -- | 'True' = use IIR for negative hybrid noise shaping
       , bfIIRShaping     ∷ !Bool
       -- | 'True' = false stereo (data is mono but output is stereo)
@@ -133,12 +136,11 @@ instance Binary BlockFlags where
                       putBit $ bfFalseStereo bf
                       putBit $ bfIIRShaping  bf
                       putNBits 2 (0 ∷ Word8) -- reserved
-                      putNBits 4 $ bfSamplingRate bf
+                      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
@@ -189,8 +191,74 @@ instance Binary BlockFlags where
                                      , bfFinalBlock     = finalBlock
                                      , bfLeftShift      = leftShift
                                      , bfMaxMagnitude   = maxMagnitude
-                                     , bfSamplingRate   = samplingRate
+                                     , bfSamplingRate   = decodeSamplingRate samplingRate
                                      , bfIIRShaping     = iirShaping
                                      , bfFalseStereo    = falseStereo
                                      }
              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
+
+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
+
+-- | 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
+    = 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'
+        Just (_, src')
+            → findNextHeader src'