Add opus_compare source to repo, call it from Haskell for CI tests

.github/workflows/test.yaml → .github/workflows/run_tests.yaml

@@ -29,6 +29,7 @@ jobs:
     runs-on: ${{ matrix.os }}
     strategy:
       matrix: ${{ fromJSON(needs.generate-matrix.outputs.matrix) }}
+      fail-fast: false
     steps:
       - name: Checkout the repository
         uses: actions/checkout@v4
@@ -73,6 +74,11 @@ jobs:
           restore-keys: |
             ${{ runner.os }}-${{ matrix.ghc }}-
 
+      - name: Download Opus test vectors
+        # This creates a folder called opus_newvectors with the test vectors
+        shell: bash
+        run: curl -L https://opus-codec.org/static/testvectors/opus_testvectors-rfc8251.tar.gz | tar -xz
+
       - name: Run the tests
         # Use --enable-tests until https://github.com/haskell/cabal/issues/7883
         # is fixed, as otherwise cabal test can sometimes reach a local maxima

.gitignore

@@ -5,4 +5,3 @@ TAGS
 dist-newstyle/
 opus_newvectors/
 tmp.out
-opus_compare*

README.md

@@ -8,3 +8,4 @@ $ curl -OL https://opus-codec.org/docs/opus_testvectors-rfc8251.tar.gz
 ```
 
 
+test/opus_compare.c is taken as-is from Xiph.Org Foundation under the BSD-3 license.

opus.cabal

@@ -40,6 +40,8 @@ tested-with:         GHC ==9.4.8
 extra-source-files:
     README.md
     ChangeLog.md
+    test/opus_compare_wrapper.c
+    test/opus_compare.c
 
 source-repository head
   type:     git
@@ -71,10 +73,13 @@ test-suite opus-test
   default-language:    Haskell2010
   hs-source-dirs:
       test
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  other-modules:       OpusCompare
+  c-sources:           test/opus_compare_wrapper.c
+  include-dirs:        test
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base,
                        opus,
                        bytestring,
                        hspec,
                        microlens,
-                       process
+                       directory

test/OpusCompare.hs

@@ -0,0 +1,46 @@
+-- | This module is a wrapper around opus_compare.c.
+-- Calling 'compareFiles' is equivalent to running the opus_compare executable.
+-- Due to conflicting definitions of "main" (one in opus_compare and one in our
+-- Haskell program), we assume that opus_compare has been compiled with a define
+-- that renames its main function to "opus_compare_main".
+module OpusCompare where
+
+import           Codec.Audio.Opus.Internal.Opus
+import           Foreign
+import           Foreign.C.Types
+import           Foreign.C.String
+
+-- | Channel type
+data Channel = Mono | Stereo
+  deriving (Eq, Show)
+
+-- | Compares two Opus files using the opus_compare executable code. The result
+-- is True if the files are quality-wise identical (which doesn't necessarily
+-- mean that they are byte-wise identical due to entropy in the Opus encoding).
+-- The result is False if the files are measurably different.
+compareFiles :: Channel -> SamplingRate -> FilePath -> FilePath -> IO Bool
+compareFiles channel samplingRate filePath1 filePath2 =
+    withCString "opus_compare" $ \cProgramName ->
+      withCString "-r" $ \cSROpt ->  -- sampling rate option
+        withCString (show $ unSamplingRate samplingRate) $ \cSRVal -> -- sampling rate value
+          withCString filePath1 $ \cFile1 -> -- first file
+            withCString filePath2 $ \cFile2 -> -- second file
+              if channel == Mono
+                then allocaArray 5 $ \p -> do
+                  pokeArray p [cProgramName, cSROpt, cSRVal, cFile1, cFile2]
+                  c_opus_compare_main 5 p >>= \r -> return (r == 0)
+                else withCString "-s" $ \cSOpt -> -- stereo option
+                  allocaArray 6 $ \p -> do
+                    pokeArray p [cProgramName, cSOpt, cSROpt, cSRVal, cFile1, cFile2]
+                    c_opus_compare_main 6 p >>= \r -> return (r == 0)
+
+-- | Call the opus_compare_main function, which should be the main function
+-- within opus_compare.c. We assume that when compiling opus_compare.c, a
+-- define was used to rename the main function to "opus_compare_main".
+foreign import ccall unsafe "opus_compare_wrapper.c opus_compare_main"
+    c_opus_compare_main
+      :: Int
+      -- ^ number of arguments
+      -> Ptr (Ptr CChar)
+      -- ^ arguments
+      -> IO Int

test/Spec.hs

@@ -9,10 +9,9 @@ import qualified Data.ByteString          as B
 import           Data.Bits
 import           Data.List
 import           Data.Word (Word8)
-import           System.Exit
-import           System.Process
+import           System.Directory (doesDirectoryExist)
 import           Test.Hspec
-
+import qualified OpusCompare as Opus
 
 cfgs :: [EncoderConfig]
 cfgs = [mkEncoderConfig sr s c | sr <- srs, s <- ss, c <- cs]
@@ -31,12 +30,10 @@ 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"
+onlyIfTestVectorsExist :: IO () -> IO ()
+onlyIfTestVectorsExist action = do
+  exists <- doesDirectoryExist "opus_newvectors"
+  if exists then action else fail "opus_newvectors directory not found"
 
 decodeFile :: DecoderConfig -> B.ByteString -> IO B.ByteString
 decodeFile decoderCfg bytes = do
@@ -78,49 +75,22 @@ 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
+  around_ onlyIfTestVectorsExist $ do
+    -- These tests require 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 = mkDecoderConfig 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
+          Opus.compareFiles Opus.Mono opusSR48k ("opus_newvectors/testvector" <> file <> "m.dec") "tmp.out" >>= shouldBe True
 
     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 = mkDecoderConfig 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
+          Opus.compareFiles Opus.Stereo opusSR48k ("opus_newvectors/testvector" <> file <> ".dec") "tmp.out" >>= shouldBe True
 
 
 {-