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