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     , readBlocks
  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 Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet)
  21 import qualified Data.Binary.Strict.BitGet as BG
  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 -- Be aware; the Get monad is like a strict State monad so the entire
  48 -- sub-blocks are parsed at once. This might not be what you want
  49 -- (like me).
  50 getSubBlocks ∷ Integral n ⇒ n → Get [SubBlock]
  51 getSubBlocks 0 = return $! []
  52 getSubBlocks !blockSize
  53     = do before ← bytesRead
  54          meta   ← get
  55          after  ← bytesRead
  56          rest   ← getSubBlocks $ blockSize - fromIntegral (after - before)
  57          return (meta : rest)
  58
  59 -- The lazy version.
  60 getSubBlocksLazily ∷ Integral n
  61                    ⇒ L.ByteString
  62                    → n
  63                    → (# [SubBlock], L.ByteString #)
  64 getSubBlocksLazily src          0 = (# [], src #)
  65 getSubBlocksLazily src !blockSize
  66     = let (sub, src', consumed)
  67               = runGetState get src 0
  68           (# subs, src'' #)
  69               = getSubBlocksLazily src' $
  70                 blockSize - fromIntegral consumed
  71       in
  72         (# sub : subs, src'' #)
  73
  74 -- | The preamble to every block in both the .wv and .wvc files.
  75 data BlockHeader
  76     = BlockHeader {
  77       -- | size of entire block (excluding the header)
  78         bhSize         ∷ !Word32
  79       -- | 0x402 to 0x410 are currently valid for decode
  80       , bhVersion      ∷ !Word16
  81       -- | track number (0 if not used, like now)
  82       , bhTrackNo      ∷ !Word8
  83       -- | track sub-index (0 if not used, like now)
  84       , bhIndexNo      ∷ !Word8
  85       -- | total samples for entire file, but this is only valid if
  86       --   'bhBlockIndex' == 0 and a value of -1 indicates unknown
  87       --   length
  88       , bhTotalSamples ∷ !Word32
  89       -- | index of first sample in block relative to beginning of
  90       --   file (normally this would start at 0 for the first block)
  91       , bhBlockIndex   ∷ !Word32
  92       -- | number of samples in this block (0 = no audio)
  93       , bhBlockSamples ∷ !Word32
  94       -- | various flags for id and decoding
  95       , bhFlags        ∷ !BlockFlags
  96       -- | crc for actual decoded data
  97       , bhCRC          ∷ !Word32
  98       }
  99     deriving (Show, Eq)
 100
 101 instance Binary BlockHeader where
 102     put bh
 103         = do putWord8 119 -- 'w'
 104              putWord8 118 -- 'v'
 105              putWord8 112 -- 'p'
 106              putWord8 107 -- 'k'
 107              putWord32le $ bhSize         bh + 32 - 8
 108              putWord16le $ bhVersion      bh
 109              putWord8    $ bhTrackNo      bh
 110              putWord8    $ bhIndexNo      bh
 111              putWord32le $ bhTotalSamples bh
 112              putWord32le $ bhBlockIndex   bh
 113              putWord32le $ bhBlockSamples bh
 114              put         $ bhFlags        bh
 115              putWord32le $ bhCRC          bh
 116
 117     get = do skip 4 -- "wvpk"
 118              size         ← getWord32le
 119              version      ← getWord16le
 120              trackNo      ← getWord8
 121              indexNo      ← getWord8
 122              totalSamples ← getWord32le
 123              blockIndex   ← getWord32le
 124              blockSamples ← getWord32le
 125              flags        ← get
 126              crc          ← getWord32le
 127              return $! BlockHeader {
 128                               bhSize         = size + 8 - 32
 129                             , bhVersion      = version
 130                             , bhTrackNo      = trackNo
 131                             , bhIndexNo      = indexNo
 132                             , bhTotalSamples = totalSamples
 133                             , bhBlockIndex   = blockIndex
 134                             , bhBlockSamples = blockSamples
 135                             , bhFlags        = flags
 136                             , bhCRC          = crc
 137                             }
 138
 139 -- | Various flags for decoding blocks
 140 data BlockFlags
 141     = BlockFlags {
 142       -- | 1 <= n <= 4
 143         bfBytesPerSample ∷ !Word8
 144       -- | 'False' = stereo output; 'True' = mono output
 145       , bfMono           ∷ !Bool
 146       -- | 'False' = lossless mode; 'True' = hybrid mode
 147       , bfHybrid         ∷ !Bool
 148       -- | 'False' = true stereo; 'True' = joint stereo (mid/side)
 149       , bfJointStereo    ∷ !Bool
 150       -- | 'False' = independent channels; 'True' = cross-channel
 151       --   decorrelation
 152       , bfCrossDecorr    ∷ !Bool
 153       -- | 'False' = flat noise spectrum in hybrid; 'True' = hybrid
 154       --   noise shaping
 155       , bfHybridShape    ∷ !Bool
 156       -- | 'False' = integer data; 'True' = floating point data
 157       , bfFloatData      ∷ !Bool
 158       -- | 'True' = extended size integers (> 24-bit); 'False' =
 159       --   shifted integers
 160       , bfExtendedInt    ∷ !Bool
 161       -- | 'False' = hybrid mode parameters control noise level;
 162       --   'True' = hybrid mode parameters control bitrate
 163       , bfHybridBitrate  ∷ !Bool
 164       -- | 'True' = hybrid noise balanced between channels
 165       , bfHybridBalance  ∷ !Bool
 166       -- | 'True' = initial block in sequence (for multichannel)
 167       , bfInitialBlock   ∷ !Bool
 168       -- | 'True' = final block in sequence (for multichannel)
 169       , bfFinalBlock     ∷ !Bool
 170       -- | amount of data left-shift after decode (0-31 places)
 171       , bfLeftShift      ∷ !Word8
 172       -- | maximum magnitude of decoded data (number of bits integers
 173       --   require minus 1)
 174       , bfMaxMagnitude   ∷ !Word8
 175       -- | sampling rate ('Nothing' = unknown/custom)
 176       , bfSamplingRate   ∷ !(S.Maybe Int)
 177       -- | 'True' = use IIR for negative hybrid noise shaping
 178       , bfIIRShaping     ∷ !Bool
 179       -- | 'True' = false stereo (data is mono but output is stereo)
 180       , bfFalseStereo    ∷ !Bool
 181       }
 182     deriving (Show, Eq)
 183
 184 instance Binary BlockFlags where
 185     put bf
 186         = let !bs = runBitPut $
 187                     do putBit False -- reserved
 188                        putBit $ bfFalseStereo bf
 189                        putBit $ bfIIRShaping  bf
 190                        putNBits 2 (0 ∷ Word8) -- reserved
 191                        putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf
 192                        putNBits 5 $ bfMaxMagnitude bf
 193                        putNBits 5 $ bfLeftShift    bf
 194                        putBit $ bfFinalBlock    bf
 195                        putBit $ bfInitialBlock  bf
 196                        putBit $ bfHybridBalance bf
 197                        putBit $ bfHybridBitrate bf
 198                        putBit $ bfExtendedInt   bf
 199                        putBit $ bfFloatData     bf
 200                        putBit $ bfHybridShape   bf
 201                        putBit $ bfCrossDecorr   bf
 202                        putBit $ bfJointStereo   bf
 203                        putBit $ bfHybrid        bf
 204                        putBit $ bfMono          bf
 205                        putNBits 2 $! bfBytesPerSample bf - 1
 206           in
 207             putLazyByteString (L.reverse bs)
 208
 209     get = do bs ← getBytes 4
 210              let !r = runBitGet (S.reverse bs) $
 211                       do BG.skip 1 -- reserved
 212                          falseStereo    ← getBit
 213                          iirShaping     ← getBit
 214                          BG.skip 2 -- reserved
 215                          samplingRate   ← getAsWord8 4
 216                          maxMagnitude   ← getAsWord8 5
 217                          leftShift      ← getAsWord8 5
 218                          finalBlock     ← getBit
 219                          initialBlock   ← getBit
 220                          hybridBalance  ← getBit
 221                          hybridBitrate  ← getBit
 222                          extendedInt    ← getBit
 223                          floatData      ← getBit
 224                          hybridShape    ← getBit
 225                          crossDecorr    ← getBit
 226                          jointStereo    ← getBit
 227                          hybrid         ← getBit
 228                          mono           ← getBit
 229                          bytesPerSample ← getAsWord8 2
 230                          return $! BlockFlags {
 231                                       bfBytesPerSample = bytesPerSample + 1
 232                                     , bfMono           = mono
 233                                     , bfHybrid         = hybrid
 234                                     , bfJointStereo    = jointStereo
 235                                     , bfCrossDecorr    = crossDecorr
 236                                     , bfHybridShape    = hybridShape
 237                                     , bfFloatData      = floatData
 238                                     , bfExtendedInt    = extendedInt
 239                                     , bfHybridBitrate  = hybridBitrate
 240                                     , bfHybridBalance  = hybridBalance
 241                                     , bfInitialBlock   = initialBlock
 242                                     , bfFinalBlock     = finalBlock
 243                                     , bfLeftShift      = leftShift
 244                                     , bfMaxMagnitude   = maxMagnitude
 245                                     , bfSamplingRate   = decodeSamplingRate samplingRate
 246                                     , bfIIRShaping     = iirShaping
 247                                     , bfFalseStereo    = falseStereo
 248                                     }
 249              case r of
 250                Left err → fail err
 251                Right bf → return $! bf
 252
 253 encodeSamplingRate ∷ S.Maybe Int → Word8
 254 encodeSamplingRate (S.Just   6000) = 0x00
 255 encodeSamplingRate (S.Just   8000) = 0x01
 256 encodeSamplingRate (S.Just   9600) = 0x02
 257 encodeSamplingRate (S.Just  11025) = 0x03
 258 encodeSamplingRate (S.Just  12000) = 0x04
 259 encodeSamplingRate (S.Just  16000) = 0x05
 260 encodeSamplingRate (S.Just  22050) = 0x06
 261 encodeSamplingRate (S.Just  24000) = 0x07
 262 encodeSamplingRate (S.Just  32000) = 0x08
 263 encodeSamplingRate (S.Just  44100) = 0x09
 264 encodeSamplingRate (S.Just  48000) = 0x0A
 265 encodeSamplingRate (S.Just  64000) = 0x0B
 266 encodeSamplingRate (S.Just  88200) = 0x0C
 267 encodeSamplingRate (S.Just  96000) = 0x0D
 268 encodeSamplingRate (S.Just 192000) = 0x0E
 269 encodeSamplingRate               _ = 0x0F
 270
 271 decodeSamplingRate ∷ Word8 → S.Maybe Int
 272 decodeSamplingRate 0x00 = S.Just   6000
 273 decodeSamplingRate 0x01 = S.Just   8000
 274 decodeSamplingRate 0x02 = S.Just   9600
 275 decodeSamplingRate 0x03 = S.Just  11025
 276 decodeSamplingRate 0x04 = S.Just  12000
 277 decodeSamplingRate 0x05 = S.Just  16000
 278 decodeSamplingRate 0x06 = S.Just  22025
 279 decodeSamplingRate 0x07 = S.Just  24000
 280 decodeSamplingRate 0x08 = S.Just  32000
 281 decodeSamplingRate 0x09 = S.Just  44100
 282 decodeSamplingRate 0x0A = S.Just  48000
 283 decodeSamplingRate 0x0B = S.Just  64000
 284 decodeSamplingRate 0x0C = S.Just  88200
 285 decodeSamplingRate 0x0D = S.Just  96000
 286 decodeSamplingRate 0x0E = S.Just 192000
 287 decodeSamplingRate    _ =     S.Nothing
 288
 289 -- | Read WavPack blocks in a given stream lazily.
 290 readBlocks ∷ L.ByteString → [Block]
 291 readBlocks src
 292     = case findNextBlock src of
 293         (# S.Just block, src' #)
 294             → block : readBlocks src'
 295         (# S.Nothing, _ #)
 296             → []
 297
 298 findNextBlock ∷ L.ByteString
 299               → (# S.Maybe Block, L.ByteString #)
 300 findNextBlock src
 301     = case L.uncons src of
 302         Nothing
 303             → (# S.Nothing, L.empty #)
 304
 305         Just (119, _) -- 'w'
 306             → tryGetBlock src
 307
 308         Just (_, src')
 309             → findNextBlock src'
 310
 311 tryGetBlock ∷ L.ByteString → (# S.Maybe Block, L.ByteString #)
 312 tryGetBlock src
 313     = case L.splitAt 32 src of
 314         (header, rest)
 315             → case L.length header ≡ 32 of
 316                  True
 317                      → case L.take 4 header ≡ headerMagic of
 318                           True
 319                               -- Found the magic "wvpk". Let's parse
 320                               -- the header and see if it's really a
 321                               -- header we can accept.
 322                               → case runGet get header of
 323                                    bh → if isGoodHeader bh then
 324                                              case getSubBlocksLazily rest $ bhSize bh of
 325                                                (# subs, rest' #)
 326                                                    → let !blk = Block {
 327                                                                    blockHeader   = bh
 328                                                                  , blockMetadata = subs
 329                                                                  }
 330                                                       in
 331                                                         (# S.Just blk, rest' #)
 332                                          else
 333                                              findNextBlock $ L.tail src
 334                           False
 335                               → findNextBlock $ L.tail src
 336                  False
 337                      → (# S.Nothing, L.empty #)
 338
 339 headerMagic ∷ L.ByteString
 340 headerMagic = L.pack [119, 118, 112, 107] -- "wvpk"
 341
 342 isGoodHeader ∷ BlockHeader → Bool
 343 isGoodHeader bh
 344     -- Rule #1: bhSize + 32 - 8 ≡ 0 (mod 2)
 345     | odd $ bhSize bh               = False
 346     -- Rule #2: bhSize + 32 - 8 ≤ 0x00100000
 347     | bhSize bh + 32 - 8 > 0x100000 = False
 348     -- Rule #3: bhSize + 32 - 8 > 24
 349     | bhSize bh + 32 - 8 ≤ 24      = False
 350     -- Rule #4: 0x402 ≤ bhVersion ≤ 0x410
 351     | bhVersion bh < 0x402          = False
 352     | bhVersion bh > 0x410          = False
 353     -- Rule #5: bhBlockSamples < 0x00030000
 354     | bhBlockSamples bh ≥ 0x30000  = False
 355     -- Now it passed all the tests...
 356     | otherwise                     = True