{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Codec.Audio.Wave
(
Wave (..)
, WaveFormat (..)
, SampleFormat (..)
, SpeakerPosition (..)
, WaveException (..)
, waveByteRate
, waveBitRate
, waveBitsPerSample
, waveBlockAlign
, waveChannels
, waveDuration
, speakerMono
, speakerStereo
, speakerQuad
, speakerSurround
, speaker5_1
, speaker7_1
, speaker5_1Surround
, speaker7_1Surround
, readWaveFile
, writeWaveFile )
where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.ByteString (ByteString)
import Data.Data (Data)
import Data.Maybe (mapMaybe, isNothing)
import Data.Monoid ((<>))
import Data.Set (Set)
import Data.Typeable
import Data.Word
import System.IO
import qualified Data.ByteString as B
import qualified Data.Serialize as S
import qualified Data.Set as E
data Wave = Wave
{ waveFileFormat :: !WaveFormat
, waveSampleRate :: !Word32
, waveSampleFormat :: !SampleFormat
, waveChannelMask :: !(Set SpeakerPosition)
, waveDataOffset :: !Word32
, waveDataSize :: !Word64
, waveSamplesTotal :: !Word64
, waveOtherChunks :: [(ByteString, ByteString)]
} deriving (Show, Read, Eq, Ord, Typeable, Data)
defaultWave :: Wave
defaultWave = Wave
{ waveFileFormat = WaveVanilla
, waveSampleRate = 44100
, waveSampleFormat = SampleFormatPcmInt 16
, waveChannelMask = defaultSpeakerSet 2
, waveDataOffset = 0
, waveDataSize = 0
, waveSamplesTotal = 0
, waveOtherChunks = []
}
data WaveFormat
= WaveVanilla
| WaveRF64
deriving (Show, Read, Eq, Ord, Bounded, Enum, Typeable, Data)
data SampleFormat
= SampleFormatPcmInt Word16
| SampleFormatIeeeFloat32Bit
| SampleFormatIeeeFloat64Bit
deriving (Show, Read, Eq, Ord, Typeable, Data)
data SpeakerPosition
= SpeakerFrontLeft
| SpeakerFrontRight
| SpeakerFrontCenter
| SpeakerLowFrequency
| SpeakerBackLeft
| SpeakerBackRight
| SpeakerFrontLeftOfCenter
| SpeakerFrontRightOfCenter
| SpeakerBackCenter
| SpeakerSideLeft
| SpeakerSideRight
| SpeakerTopCenter
| SpeakerTopFrontLeft
| SpeakerTopFrontCenter
| SpeakerTopFrontRight
| SpeakerTopBackLeft
| SpeakerTopBackCenter
| SpeakerTopBackRight
deriving (Show, Read, Eq, Ord, Bounded, Enum, Typeable, Data)
data WaveException
= BadFileFormat String FilePath
| NonDataChunkIsTooLong ByteString FilePath
| NonPcmFormatButMissingFact FilePath
deriving (Show, Read, Eq, Typeable, Data)
instance Exception WaveException
data Chunk m = Chunk
{ chunkTag :: !ByteString
, chunkSize :: !Word32
, chunkBody :: !(m ByteString)
}
data Ds64 = Ds64
{ ds64RiffSize :: !Word64
, ds64DataSize :: !Word64
, ds64SamplesTotal :: !Word64
}
defaultDs64 :: Ds64
defaultDs64 = Ds64
{ ds64RiffSize = 0
, ds64DataSize = 0
, ds64SamplesTotal = 0
}
type GiveUp = forall a. (FilePath -> WaveException) -> IO a
type LiftGet = forall a. IO (Either String a) -> IO a
waveByteRate :: Wave -> Word32
waveByteRate wave =
waveSampleRate wave * fromIntegral (waveBlockAlign wave)
waveBitRate :: Wave -> Double
waveBitRate = (/ 125) . fromIntegral . waveByteRate
waveBitsPerSample :: Wave -> Word16
waveBitsPerSample Wave {..} =
case waveSampleFormat of
SampleFormatPcmInt bps -> bps
SampleFormatIeeeFloat32Bit -> 32
SampleFormatIeeeFloat64Bit -> 64
waveBlockAlign :: Wave -> Word16
waveBlockAlign wave = waveChannels wave * bytesPerSample
where
bytesPerSample = roundBitsPerSample (waveBitsPerSample wave) `quot` 8
waveChannels :: Wave -> Word16
waveChannels Wave {..} = fromIntegral (E.size waveChannelMask)
waveDuration :: Wave -> Double
waveDuration wave =
fromIntegral (waveSamplesTotal wave) / fromIntegral (waveSampleRate wave)
speakerMono :: Set SpeakerPosition
speakerMono = E.fromList [SpeakerFrontCenter]
speakerStereo :: Set SpeakerPosition
speakerStereo = E.fromList [SpeakerFrontLeft,SpeakerFrontRight]
speakerQuad :: Set SpeakerPosition
speakerQuad = E.fromList
[ SpeakerFrontLeft
, SpeakerFrontRight
, SpeakerBackLeft
, SpeakerBackRight ]
speakerSurround :: Set SpeakerPosition
speakerSurround = E.fromList
[ SpeakerFrontLeft
, SpeakerFrontRight
, SpeakerFrontCenter
, SpeakerBackCenter ]
speaker5_1 :: Set SpeakerPosition
speaker5_1 = E.fromList
[ SpeakerFrontLeft
, SpeakerFrontRight
, SpeakerFrontCenter
, SpeakerBackLeft
, SpeakerBackRight
, SpeakerLowFrequency ]
speaker7_1 :: Set SpeakerPosition
speaker7_1 = E.fromList
[ SpeakerFrontLeft
, SpeakerFrontRight
, SpeakerFrontCenter
, SpeakerBackLeft
, SpeakerBackRight
, SpeakerFrontLeftOfCenter
, SpeakerFrontRightOfCenter
, SpeakerLowFrequency ]
speaker5_1Surround :: Set SpeakerPosition
speaker5_1Surround = E.fromList
[ SpeakerFrontLeft
, SpeakerFrontRight
, SpeakerFrontCenter
, SpeakerSideLeft
, SpeakerSideRight
, SpeakerLowFrequency ]
speaker7_1Surround :: Set SpeakerPosition
speaker7_1Surround = E.fromList
[ SpeakerFrontLeft
, SpeakerFrontRight
, SpeakerFrontCenter
, SpeakerBackLeft
, SpeakerBackRight
, SpeakerSideLeft
, SpeakerSideRight
, SpeakerLowFrequency ]
readWaveFile :: MonadIO m
=> FilePath
-> m Wave
readWaveFile path = liftIO . withBinaryFile path ReadMode $ \h -> do
let giveup f = throwIO (f path)
liftGet m = do
r <- m
case r of
Left msg -> throwIO (BadFileFormat msg path)
Right x -> return x
outerChunk <- liftGet (readChunk h 0)
case chunkTag outerChunk of
"RIFF" -> readWaveVanilla h giveup liftGet
"RF64" -> readWaveRF64 h giveup liftGet
_ -> giveup (BadFileFormat "Can't locate RIFF/RF64 tag")
readWaveVanilla
:: Handle
-> GiveUp
-> LiftGet
-> IO Wave
readWaveVanilla h giveup liftGet = do
grabWaveTag h giveup
grabWaveChunks h giveup liftGet Nothing Nothing
defaultWave { waveFileFormat = WaveVanilla
}
readWaveRF64
:: Handle
-> GiveUp
-> LiftGet
-> IO Wave
readWaveRF64 h giveup liftGet = do
grabWaveTag h giveup
mds64 <- liftGet (readChunk h 0xffff)
unless (chunkTag mds64 == "ds64") $
giveup (BadFileFormat "Can't find ds64 chunk")
Ds64 {..} <- case chunkBody mds64 of
Nothing -> giveup (NonDataChunkIsTooLong "ds64")
Just body -> liftGet (return $ readDs64 body)
grabWaveChunks h giveup liftGet (Just ds64DataSize) (Just ds64SamplesTotal)
defaultWave { waveFileFormat = WaveRF64
, waveSamplesTotal = 0xffffffff
}
grabWaveTag :: Handle -> GiveUp -> IO ()
grabWaveTag h giveup = do
waveId <- B.hGet h 4
unless (waveId == "WAVE") $
giveup (BadFileFormat "Can't find WAVE format tag")
grabWaveChunks
:: Handle
-> GiveUp
-> LiftGet
-> Maybe Word64
-> Maybe Word64
-> Wave
-> IO Wave
grabWaveChunks h giveup liftGet mdataSize msamplesTotal = go False
where
go seenFact wave = do
offset <- hTell h
Chunk {..} <- liftGet (readChunk h 0xffff)
case (chunkTag, chunkBody) of
("data", _) -> do
let nonPcm = isNonPcm (waveSampleFormat wave)
when (nonPcm && not seenFact && isNothing msamplesTotal) $
giveup NonPcmFormatButMissingFact
let dataSize =
case (chunkSize == 0xffffffff, mdataSize) of
(True, Just dataSize') -> dataSize'
_ -> fromIntegral chunkSize
return wave
{ waveDataOffset = fromIntegral offset + 8
, waveDataSize = dataSize
, waveSamplesTotal =
case (waveSamplesTotal wave == 0xffffffff, msamplesTotal) of
(True, Just samplesTotal) -> samplesTotal
_ ->
if nonPcm
then waveSamplesTotal wave
else pcmSamplesTotal wave { waveDataSize = dataSize }
, waveOtherChunks = reverse (waveOtherChunks wave) }
(tag, Nothing) ->
giveup (NonDataChunkIsTooLong tag)
("fmt ", Just body) ->
liftGet (return $ readWaveFmt wave body) >>= go seenFact
("fact", Just body) -> do
samplesTotal <- liftGet (return $ readFact body)
go True wave { waveSamplesTotal = fromIntegral samplesTotal }
(tag, Just body) ->
go seenFact
wave { waveOtherChunks = (tag, body) : waveOtherChunks wave }
readDs64 :: ByteString -> Either String Ds64
readDs64 bytes = flip S.runGet bytes $ do
ds64RiffSize <- S.getWord64le
ds64DataSize <- S.getWord64le
ds64SamplesTotal <- S.getWord64le
return Ds64 {..}
readWaveFmt :: Wave -> ByteString -> Either String Wave
readWaveFmt wave = S.runGet $ do
format <- S.getWord16le
unless ( format == waveFormatPcm ||
format == waveFormatIeeeFloat ||
format == waveFormatExtensible ) $
fail "Unsupported audio format specified in fmt chunk"
let extensible = format == waveFormatExtensible
channels <- S.getWord16le
sampleRate <- S.getWord32le
S.skip 4
S.skip 2
bps <- S.getWord16le
hasExtSize <- not <$> S.isEmpty
extSize <- if hasExtSize
then S.getWord16le
else return 0
when (extSize < 22 && extensible) $
fail "The format is extensible, but extra params are shorter than 22 bytes"
bitsPerSample <- if extensible
then S.getWord16le
else return bps
channelMask <- if extensible
then fromSpeakerMask <$> S.getWord32le
else return (defaultSpeakerSet channels)
extGuid <- if extensible
then S.getByteString 16
else return $ if format == waveFormatPcm
then ksdataformatSubtypePcm
else ksdataformatSubtypeIeeeFloat
when (extGuid /= ksdataformatSubtypePcm &&
extGuid /= ksdataformatSubtypeIeeeFloat) $
fail ("Unknown or unsupported GUID in extensible fmt chunk" ++ show extGuid)
let ieeeFloat = extGuid == ksdataformatSubtypeIeeeFloat
when (ieeeFloat && not (bitsPerSample == 32 || bitsPerSample == 64)) $
fail "The sample format is IEEE Float, but bits per sample is not 32 or 64"
return wave
{ waveSampleRate = sampleRate
, waveSampleFormat =
if ieeeFloat
then if bitsPerSample == 32
then SampleFormatIeeeFloat32Bit
else SampleFormatIeeeFloat64Bit
else SampleFormatPcmInt bitsPerSample
, waveChannelMask = channelMask }
readFact :: ByteString -> Either String Word32
readFact = S.runGet S.getWord32le
readChunk
:: Handle
-> Word32
-> IO (Either String (Chunk Maybe))
readChunk h maxSize = do
bytes <- B.hGet h 8
let echunk = flip S.runGet bytes $ do
chunkTag <- S.getBytes 4
chunkSize <- S.getWord32le
let chunkBody = Nothing
return Chunk {..}
case echunk of
Left msg -> return (Left msg)
Right chunk@Chunk {..} -> do
body <- if chunkSize <= maxSize
then Just <$> B.hGet h (fromIntegral chunkSize)
else return Nothing
(return . Right) chunk { chunkBody = body }
writeWaveFile :: MonadIO m
=> FilePath
-> Wave
-> (Handle -> IO ())
-> m ()
writeWaveFile path wave writeData = liftIO . withBinaryFile path WriteMode $ \h ->
case waveFileFormat wave of
WaveVanilla -> writeWaveVanilla h wave writeData
WaveRF64 -> writeWaveRF64 h wave writeData
writeWaveVanilla
:: Handle
-> Wave
-> (Handle -> IO ())
-> IO ()
writeWaveVanilla h wave writeData = do
let nonPcm = isNonPcm (waveSampleFormat wave)
beforeOuter <- hTell h
writeChunk h (Chunk "RIFF" 0 writeNoData)
B.hPut h "WAVE"
writeBsChunk h "fmt " (renderFmtChunk wave)
beforeFact <- hTell h
when nonPcm $
writeBsChunk h "fact" "????"
forM_ (waveOtherChunks wave) (uncurry $ writeBsChunk h)
beforeData <- hTell h
writeChunk h (Chunk "data" 0 (Left writeData))
rightAfterData <- hTell h
when (odd rightAfterData) $
B.hPut h "\0"
afterData <- hTell h
let riffSize = fromIntegral (afterData - beforeOuter - 8)
dataSize = fromIntegral (afterData - beforeData - 8)
samplesTotal = fromIntegral $
pcmSamplesTotal wave { waveDataSize = fromIntegral dataSize }
when nonPcm $ do
hSeek h AbsoluteSeek beforeFact
writeBsChunk h "fact" (renderFactChunk samplesTotal)
hSeek h AbsoluteSeek beforeData
writeChunk h (Chunk "data" dataSize writeNoData)
hSeek h AbsoluteSeek beforeOuter
writeChunk h (Chunk "RIFF" riffSize writeNoData)
writeWaveRF64 :: Handle -> Wave -> (Handle -> IO ()) -> IO ()
writeWaveRF64 h wave writeData = do
beforeOuter <- hTell h
writeChunk h (Chunk "RF64" 0xffffffff writeNoData)
B.hPut h "WAVE"
beforeDs64 <- hTell h
writeBsChunk h "ds64" (renderDs64Chunk defaultDs64)
writeBsChunk h "fmt " (renderFmtChunk wave)
forM_ (waveOtherChunks wave) (uncurry $ writeBsChunk h)
beforeData <- hTell h
writeChunk h (Chunk "data" 0xffffffff (Left writeData))
rightAfterData <- hTell h
when (odd rightAfterData) $
B.hPut h "\0"
afterData <- hTell h
let ds64RiffSize = fromIntegral (afterData - beforeOuter - 8)
ds64DataSize = fromIntegral (afterData - beforeData - 8)
ds64SamplesTotal = pcmSamplesTotal wave { waveDataSize = ds64DataSize }
ds64Chunk = Ds64 {..}
hSeek h AbsoluteSeek beforeDs64
writeBsChunk h "ds64" (renderDs64Chunk ds64Chunk)
writeNoData :: Either (Handle -> IO ()) a
writeNoData = (Left . const . return) ()
writeBsChunk
:: Handle
-> ByteString
-> ByteString
-> IO ()
writeBsChunk h chunkTag body =
let chunkSize = fromIntegral (B.length body)
chunkBody = Right body
in writeChunk h Chunk {..}
renderDs64Chunk :: Ds64 -> ByteString
renderDs64Chunk Ds64 {..} = S.runPut $ do
S.putWord64le ds64RiffSize
S.putWord64le ds64DataSize
S.putWord64le ds64SamplesTotal
renderFmtChunk :: Wave -> ByteString
renderFmtChunk wave@Wave {..} = S.runPut $ do
let extensible = isExtensibleFmt wave
fmt = case waveSampleFormat of
SampleFormatPcmInt _ -> waveFormatPcm
SampleFormatIeeeFloat32Bit -> waveFormatIeeeFloat
SampleFormatIeeeFloat64Bit -> waveFormatIeeeFloat
bps = waveBitsPerSample wave
S.putWord16le (if extensible then waveFormatExtensible else fmt)
S.putWord16le (waveChannels wave)
S.putWord32le waveSampleRate
S.putWord32le (waveByteRate wave)
S.putWord16le (waveBlockAlign wave)
S.putWord16le (roundBitsPerSample bps)
when extensible $ do
S.putWord16le 22
S.putWord16le bps
S.putWord32le (toSpeakerMask waveChannelMask)
S.putByteString $ case waveSampleFormat of
SampleFormatPcmInt _ -> ksdataformatSubtypePcm
SampleFormatIeeeFloat32Bit -> ksdataformatSubtypeIeeeFloat
SampleFormatIeeeFloat64Bit -> ksdataformatSubtypeIeeeFloat
renderFactChunk :: Word32 -> ByteString
renderFactChunk = S.runPut . S.putWord32le
writeChunk
:: Handle
-> Chunk (Either (Handle -> IO ()))
-> IO ()
writeChunk h Chunk {..} = do
let bytes = S.runPut $ do
S.putByteString (B.take 4 $ chunkTag <> B.replicate 4 0x00)
S.putWord32le chunkSize
B.hPut h bytes
case chunkBody of
Left action -> action h
Right body -> B.hPut h body
waveFormatPcm :: Word16
waveFormatPcm = 0x0001
waveFormatIeeeFloat :: Word16
waveFormatIeeeFloat = 0x0003
waveFormatExtensible :: Word16
waveFormatExtensible = 0xfffe
ksdataformatSubtypePcm :: ByteString
ksdataformatSubtypePcm =
"\x01\x00\x00\x00\x00\x00\x10\x00\x80\x00\x00\xaa\x00\x38\x9b\x71"
ksdataformatSubtypeIeeeFloat :: ByteString
ksdataformatSubtypeIeeeFloat =
"\x03\x00\x00\x00\x00\x00\x10\x00\x80\x00\x00\xaa\x00\x38\x9b\x71"
speakerToFlag :: SpeakerPosition -> Word32
speakerToFlag SpeakerFrontLeft = 0x1
speakerToFlag SpeakerFrontRight = 0x2
speakerToFlag SpeakerFrontCenter = 0x4
speakerToFlag SpeakerLowFrequency = 0x8
speakerToFlag SpeakerBackLeft = 0x10
speakerToFlag SpeakerBackRight = 0x20
speakerToFlag SpeakerFrontLeftOfCenter = 0x40
speakerToFlag SpeakerFrontRightOfCenter = 0x80
speakerToFlag SpeakerBackCenter = 0x100
speakerToFlag SpeakerSideLeft = 0x200
speakerToFlag SpeakerSideRight = 0x400
speakerToFlag SpeakerTopCenter = 0x800
speakerToFlag SpeakerTopFrontLeft = 0x1000
speakerToFlag SpeakerTopFrontCenter = 0x2000
speakerToFlag SpeakerTopFrontRight = 0x4000
speakerToFlag SpeakerTopBackLeft = 0x8000
speakerToFlag SpeakerTopBackCenter = 0x10000
speakerToFlag SpeakerTopBackRight = 0x20000
toSpeakerMask :: Set SpeakerPosition -> Word32
toSpeakerMask = E.foldl' (.|.) 0 . E.map speakerToFlag
fromSpeakerMask :: Word32 -> Set SpeakerPosition
fromSpeakerMask channelMask = E.fromList $ mapMaybe f [minBound..maxBound]
where
f sp = if speakerToFlag sp .&. channelMask > 0
then Just sp
else Nothing
defaultSpeakerSet :: Word16 -> Set SpeakerPosition
defaultSpeakerSet n = case n of
0 -> E.empty
1 -> speakerMono
2 -> speakerStereo
3 -> E.fromList [SpeakerFrontLeft,SpeakerFrontRight,SpeakerFrontCenter]
4 -> speakerQuad
5 -> E.insert SpeakerFrontCenter speakerQuad
6 -> speaker5_1
7 -> E.insert SpeakerBackCenter speaker5_1Surround
8 -> speaker7_1Surround
x -> E.fromList $ take (fromIntegral x) [minBound..maxBound]
isExtensibleFmt :: Wave -> Bool
isExtensibleFmt wave@Wave {..} =
waveChannels wave > 2 ||
waveChannelMask /= defaultSpeakerSet (waveChannels wave) ||
(waveBitsPerSample wave `rem` 8) /= 0
isNonPcm :: SampleFormat -> Bool
isNonPcm (SampleFormatPcmInt _) = False
isNonPcm SampleFormatIeeeFloat32Bit = True
isNonPcm SampleFormatIeeeFloat64Bit = True
roundBitsPerSample :: Word16 -> Word16
roundBitsPerSample n = if r /= 0 then (x + 1) * 8 else n
where
(x,r) = n `quotRem` 8
pcmSamplesTotal :: Wave -> Word64
pcmSamplesTotal wave =
waveDataSize wave `quot` fromIntegral (waveBlockAlign wave)