diff --git a/opus.cabal b/opus.cabal index 05be07b..e5e60e9 100644 --- a/opus.cabal +++ b/opus.cabal @@ -20,6 +20,8 @@ library hs-source-dirs: src exposed-modules: Codec.Audio.Opus.Encoder, Codec.Audio.Opus.Encoder.Conduit, + Codec.Audio.Opus.Decoder, + Codec.Audio.Opus.Decoder.Conduit, Codec.Audio.Opus.Types, Codec.Audio.Opus.Internal.Opus default-language: Haskell2010 @@ -54,4 +56,5 @@ test-suite hs-mumble-test http-client-tls, zlib, lens, - tar + tar, + process diff --git a/src/Codec/Audio/Opus/Decoder.hs b/src/Codec/Audio/Opus/Decoder.hs new file mode 100644 index 0000000..eddec1f --- /dev/null +++ b/src/Codec/Audio/Opus/Decoder.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Codec.Audio.Opus.Decoder + ( -- * Decoder + Decoder, OpusException(..) + -- ** create + , withOpusDecoder, opusDecoderCreate, opusDecoderDestroy + -- ** run + , opusDecode, opusDecodeLazy + -- * re-exports + , module Codec.Audio.Opus.Types + ) where + +import Codec.Audio.Opus.Internal.Opus +import Codec.Audio.Opus.Types +import Control.Lens.Fold +import Control.Lens.Operators +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Foreign + +-- | Decoder State +newtype Decoder = Decoder (ForeignPtr DecoderT, ForeignPtr ErrorCode) + deriving (Eq, Ord, Show) + +-- | allocates and initializes a decoder state. +opusDecoderCreate :: (HasDecoderConfig cfg, MonadIO m) => cfg -> m Decoder +opusDecoderCreate cfg = liftIO $ do + let cs = if isStereo then 2 else 1 + sr = cfg ^. (decoderConfig . samplingRate) + isStereo = cfg ^. decoderIsStereo + err <- mallocForeignPtr + d <- withForeignPtr err (c_opus_decoder_create sr cs) + d' <- newForeignPtr cp_opus_decoder_destroy d + let enc = Decoder (d', err) + opusLastError enc >>= maybe (pure enc) throwM + + + +-- | Decode an Opus frame. +opusDecode + :: (HasDecoderStreamConfig cfg, MonadIO m) + => Decoder -- ^ 'Decoder' state + -> cfg -- ^ max data bytes + -> ByteString -- ^ input signal (interleaved if 2 channels) + -> m ByteString +opusDecode d cfg i = + let fs = cfg ^. deStreamFrameSize + fec = cfg ^. deStreamDecodeFec + conf = cfg ^. deStreamDecoderConfig + chans = if conf ^. decoderIsStereo then 2 else 1 + pcm_length = fs * chans + in liftIO $ + BS.useAsCStringLen i $ \(i', ilen) -> + allocaArray pcm_length $ \os -> + runDecoderAction d $ \d' -> do + r <- c_opus_decode d' i' (fromIntegral ilen) os + (fromIntegral fs) (fromIntegral fec) + let l = fromIntegral r + if l < 0 then do + let mbException = ErrorCode l ^? _ErrorCodeException + case mbException of + Nothing -> throwM OpusInvalidPacket + Just x -> throwM x + else do + -- multiply by 2 because "os" is CShort i.e. Int16 + -- but CStringLen expects a CChar which is Int8 + BS.packCStringLen $ (castPtr os, (fromIntegral l) * 2 * chans) + +opusDecodeLazy :: (HasDecoderStreamConfig cfg, MonadIO m) + => Decoder -- ^ 'Decoder' state + -> cfg + -> ByteString -- ^ input signal (interleaved if 2 channels) + -> m BL.ByteString +opusDecodeLazy d cfg = fmap BL.fromStrict . opusDecode d cfg + +withOpusDecoder :: (HasDecoderConfig cfg) => MonadResource m + => cfg + -> (Decoder -> IO ()) + -> m Decoder +withOpusDecoder cfg a = + snd <$> allocate (opusDecoderCreate cfg) a + + +-- | Frees an 'Decoder'. Is normaly called automaticly +-- when 'Decoder' gets out of scope +opusDecoderDestroy :: MonadIO m => Decoder -> m () +opusDecoderDestroy (Decoder (d, err)) = liftIO $ + finalizeForeignPtr d >> finalizeForeignPtr err + + +-- | get last error from decoder +opusLastError :: MonadIO m => Decoder -> m (Maybe OpusException) +opusLastError (Decoder (_, fp)) = + liftIO $ preview _ErrorCodeException <$> withForeignPtr fp peek + +type DecoderAction a = Ptr DecoderT -> IO a + +-- | Run an 'DecoderAction'. +withDecoder' :: MonadIO m => + Decoder -> DecoderAction a -> m (Either OpusException a) +withDecoder' e@(Decoder (fp_a, _)) m = liftIO $ + withForeignPtr fp_a $ \a -> do + r <- m a + le <- opusLastError e + pure $ maybe (Right r) Left le + +-- | Run an 'DecoderAction'. Might throw an 'OpusException' +runDecoderAction :: (MonadIO m, MonadThrow m) => + Decoder -> DecoderAction a -> m a +runDecoderAction d m = withDecoder' d m >>= either throwM pure diff --git a/src/Codec/Audio/Opus/Decoder/Conduit.hs b/src/Codec/Audio/Opus/Decoder/Conduit.hs new file mode 100644 index 0000000..bf3c46e --- /dev/null +++ b/src/Codec/Audio/Opus/Decoder/Conduit.hs @@ -0,0 +1,31 @@ +module Codec.Audio.Opus.Decoder.Conduit + ( decoderC, decoderLazyC + , decoderSink + ) where + +import Codec.Audio.Opus.Decoder +import Conduit +import Control.Lens.Operators +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Conduit.Combinators +import Prelude (($)) + +decoderC :: (HasDecoderStreamConfig cfg, MonadResource m) => + cfg -> ConduitT ByteString ByteString m () +decoderC cfg = withDecoder (cfg ^. deStreamDecoderConfig) $ + \d -> mapM (opusDecode d cfg) + +decoderLazyC :: (HasDecoderStreamConfig cfg, MonadResource m) => + cfg -> ConduitT ByteString BL.ByteString m () +decoderLazyC cfg = withDecoder (cfg ^. deStreamDecoderConfig) $ + \d -> mapM (opusDecodeLazy d cfg) + +decoderSink :: (HasDecoderStreamConfig cfg, MonadResource m) => + cfg -> ConduitT ByteString o m BL.ByteString +decoderSink cfg = withDecoder (cfg ^. deStreamDecoderConfig) $ + \d -> foldMapM (opusDecodeLazy d cfg) + +withDecoder :: (HasDecoderConfig cfg, MonadResource m) => + cfg -> (Decoder -> ConduitT i o m r) -> ConduitT i o m r +withDecoder cfg = bracketP (opusDecoderCreate cfg) opusDecoderDestroy diff --git a/src/Codec/Audio/Opus/Encoder.hs b/src/Codec/Audio/Opus/Encoder.hs index 324427b..adee4ec 100644 --- a/src/Codec/Audio/Opus/Encoder.hs +++ b/src/Codec/Audio/Opus/Encoder.hs @@ -63,7 +63,6 @@ opusEncode e cfg i = if l < 0 then throwM OpusInvalidPacket else BS.packCStringLen ol - opusEncodeLazy :: (HasStreamConfig cfg, MonadIO m) => Encoder -- ^ 'Encoder' state -> cfg diff --git a/src/Codec/Audio/Opus/Internal/Opus.hsc b/src/Codec/Audio/Opus/Internal/Opus.hsc index a741e29..29722ea 100644 --- a/src/Codec/Audio/Opus/Internal/Opus.hsc +++ b/src/Codec/Audio/Opus/Internal/Opus.hsc @@ -77,6 +77,7 @@ instance Show SamplingRate where show (SamplingRate r) = mconcat [show $ r `div` 1000, "kHz"] data EncoderT +data DecoderT -- | allocates and initializes an encoder state. @@ -102,3 +103,27 @@ foreign import ccall unsafe "opus.h opus_encode" -> CString -- ^ output payload -> Int32 -- ^ max data bytes -> IO Int32 -- ^ number of bytes written or negative in case of error + +-- | allocates and initializes a decoder state. +foreign import ccall unsafe "opus.h opus_decoder_create" + c_opus_decoder_create + :: SamplingRate -- ^ sampling rate, same as encoder_create + -> Int32 -- ^ Number of channels in input signal + -> Ptr ErrorCode -- ^ 'ErrorCode' pointer + -> IO (Ptr DecoderT) + +-- | Frees a 'DecoderT' +foreign import ccall unsafe "opus.h &opus_decoder_destroy" + cp_opus_decoder_destroy + :: FunPtr (Ptr DecoderT -> IO ()) + +foreign import ccall unsafe "opus.h opus_decode" + c_opus_decode + :: Ptr DecoderT -- ^ Decoder state + -> Ptr CChar -- ^ Byte array of compressed data + -> Int32 -- ^ Exact number of bytes in the payload + -> Ptr CShort -- ^ decoded audio data + -> Int32 -- ^ max duration of the frame in samples that can fit + -> CInt -- ^ flag to request that any in-band forward error correction data be decoded. If no such data is available, the frame is decoded as if it were lost. + -> IO Int32 -- ^ Number of decoded samples, or negative in case of error + diff --git a/src/Codec/Audio/Opus/Types.hs b/src/Codec/Audio/Opus/Types.hs index 518c216..f866ac5 100644 --- a/src/Codec/Audio/Opus/Types.hs +++ b/src/Codec/Audio/Opus/Types.hs @@ -11,8 +11,12 @@ module Codec.Audio.Opus.Types -- * EncoderConfig , FrameSize , EncoderConfig, HasEncoderConfig(..), _EncoderConfig + -- * DecoderConfig + , DecoderConfig, HasDecoderConfig(..), _DecoderConfig -- * StreamConfig , StreamConfig, HasStreamConfig(..), _StreamConfig + -- * DecoderStreamConfig + , DecoderStreamConfig, HasDecoderStreamConfig(..), _DecoderStreamConfig ) where import Codec.Audio.Opus.Internal.Opus @@ -79,6 +83,17 @@ instance HasSamplingRate EncoderConfig where instance HasCodingMode EncoderConfig where codingMode = encoderCodingMode +data DecoderConfig = DecoderConfig + { _decoderSamplingRate :: SamplingRate + , _decoderIsStereo :: Bool + } deriving (Eq, Show) + +makeClassy 'DecoderConfig +makePrisms 'DecoderConfig + +instance HasSamplingRate DecoderConfig where + samplingRate = decoderSamplingRate + type FrameSize = Int @@ -99,3 +114,19 @@ instance HasSamplingRate StreamConfig where instance HasCodingMode StreamConfig where codingMode = encoderConfig . codingMode + +data DecoderStreamConfig = DecoderStreamConfig + { _deStreamDecoderConfig :: DecoderConfig + , _deStreamFrameSize :: FrameSize + , _deStreamDecodeFec :: Int + } deriving (Eq, Show) + +makeClassy ''DecoderStreamConfig +makePrisms ''DecoderStreamConfig + +instance HasDecoderConfig DecoderStreamConfig where + decoderConfig = deStreamDecoderConfig + +instance HasSamplingRate DecoderStreamConfig where + samplingRate = decoderConfig . samplingRate + diff --git a/test/Spec.hs b/test/Spec.hs index 07016eb..fd6a26a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,8 +1,16 @@ module Main(main) where import Codec.Audio.Opus.Encoder +import Codec.Audio.Opus.Decoder import Control.Lens.Operators --- import qualified Data.ByteString as BS +import Control.Exception +import Control.Monad (guard, forM_) +import qualified Data.ByteString as B +import Data.Bits +import Data.List +import Data.Word (Word8) +import System.Exit +import System.Process import Test.Hspec @@ -23,11 +31,96 @@ testEncoderCreate cfg = opusEncoderCreate cfg >>= (`shouldSatisfy` const True) +onlyIfOpusCompareExists :: IO () -> IO () +onlyIfOpusCompareExists action = do + result <- try $ readProcessWithExitCode "./opus_compare" [] "" + case (result :: Either IOException (ExitCode, String, String)) of + Right (ExitFailure 1, _, _) -> action + _ -> fail "opus_compare executable not found" + +decodeFile :: DecoderConfig -> B.ByteString -> IO B.ByteString +decodeFile decoderCfg bytes = do + decoder <- opusDecoderCreate decoderCfg + loop decoder bytes + where + + -- | Convert four unsigned bytes to a 32-bit integer. fromIntegral is + -- applied to each byte before shifting to not lose any bits. + charToInt :: [Word8] -> Int + charToInt (b1:b2:b3:b4:[]) = (fromIntegral b1) `shiftL` 24 .|. (fromIntegral b2) `shiftL` 16 .|. (fromIntegral b3) `shiftL` 8 .|. (fromIntegral b4) + charToInt _ = error "wrong length to convert to int" + + maxPacket, maxFrameSize :: Int + maxPacket = 1500 + maxFrameSize = 48000 * 2 + + -- | A simplified port of the official opus_demo.c file's decoding loop + loop decoder bytes + | B.length bytes < 8 = pure mempty + | otherwise = do + -- lines 649 to 672 in opus_demo.c + let inputLen = charToInt $ B.unpack $ B.take 4 bytes + guard $ inputLen <= maxPacket && inputLen >= 0 -- invalid payload length + + let inputEncFinalRange = charToInt $ B.unpack $ B.take 4 $ B.drop 4 bytes + let (inputData, remaining) = B.splitAt inputLen $ B.drop 8 bytes + guard $ inputLen == B.length inputData -- ran out of input, expecting inputLen but got B.length bytes + + guard $ inputLen /= 0 -- lost packets are not supported for now in this test + + -- line 783 + let outputSamples = maxFrameSize + decoded <- opusDecode decoder (_DecoderStreamConfig # (decoderCfg, outputSamples, 0)) inputData + -- recursively continue with the rest + (decoded <>) <$> loop decoder remaining main :: IO () main = hspec $ do describe "opusEncoderCreate" $ seqWithCfgs testEncoderCreate + around_ onlyIfOpusCompareExists $ do + -- These tests require the opus_compare executable to be present in the + -- project root, and the opus test vectors, downloaded from the official + -- opus website. + describe "opus mono test vectors" $ + forM_ ["01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12"] $ \file -> do + it ("mono testvector " <> file) $ do + let decoderCfg = _DecoderConfig # (opusSR48k, False) + B.readFile ("opus_newvectors/testvector" <> file <> ".bit") >>= decodeFile decoderCfg >>= B.writeFile "tmp.out" + -- Use readProcessWithExitCode to account for the fact that opus_compare + -- returns a non-zero exit code if the comparing fails. + (exitcode1, stdout1, error1) <- readProcessWithExitCode "./opus_compare" + ["-r", "48000" + , "opus_newvectors/testvector" <> file <> ".dec" + , "tmp.out" + ] "" + (exitcode2, stdout2, error2) <- readProcessWithExitCode "./opus_compare" + ["-r", "48000" + , "opus_newvectors/testvector" <> file <> "m.dec" + , "tmp.out" + ] "" + shouldSatisfy (error1, error2) $ \(a, b) -> "PASSES" `isInfixOf` a || "PASSES" `isInfixOf` b + + describe "opus stereo test vectors" $ + forM_ ["01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12"] $ \file -> do + it ("stereo testvector " <> file) $ do + let decoderCfg = _DecoderConfig # (opusSR48k, True) + B.readFile ("opus_newvectors/testvector" <> file <> ".bit") >>= decodeFile decoderCfg >>= B.writeFile "tmp.out" + -- Use readProcessWithExitCode to account for the fact that opus_compare + -- returns a non-zero exit code if the comparing fails. + (exitcode1, stdout1, error1) <- readProcessWithExitCode "./opus_compare" + [ "-s" + , "-r", "48000" + , "opus_newvectors/testvector" <> file <> ".dec" + , "tmp.out" + ] "" + (exitcode2, stdout2, error2) <- readProcessWithExitCode "./opus_compare" + [ "-s" + , "-r", "48000" + , "opus_newvectors/testvector" <> file <> "m.dec" + , "tmp.out" + ] "" + shouldSatisfy (error1, error2) $ \(a, b) -> "PASSES" `isInfixOf` a || "PASSES" `isInfixOf` b {-