Add a Decoder

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

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

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

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

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
+

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
+

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
 
 
 {-