findNextBlock

diff --git a/Codec/Audio/WavPack/Block.hs b/Codec/Audio/WavPack/Block.hs
index fe3238163e3badbb9693f2eb5f9f6289f3dff280..8b532ade781c83743856b3425ae1acf35e874451 100644 (file)
--- 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 35864b1b46bc0c9911a6b9d4a04fa2c2e87a038e..77901f445aedf505ab7e4ce117ae026ebdd147c7 100644 (file)
--- 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 4c5cf88cf6b6c895021382b9617459467faae16a..8b1f5b4dfdafbf659d46b34fc136e972ace9a5f5 100644 (file)
--- 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 bc30b7721a7da901f415f9149a1e429ad0b35c65..740e60ac06c6ad3d3c1f3b99b4f6db13466246fc 100644 (file)
--- 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