OpusFile.hs

{-# LANGUAGE ForeignFunctionInterface #-}

module Sound.OpusFile
  ( Handle(..)
  , OggOpusFile
  , openMemoryBS
  , openMemory
  , free

  , Channels(..)
  , channelCount
  , pcmTotal

  , Pcm(..)
  , decodeInt16
  ) where

import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Int (Int16, Int64)
import Foreign (ForeignPtr, Ptr)
import Foreign.C.Types (CChar, CInt(..))
import System.IO.Unsafe (unsafePerformIO)

import qualified Foreign

-- * Loading

newtype Handle = Handle (Ptr OggOpusFile)
  deriving (Eq, Show)

data OggOpusFile

openMemoryBS :: ByteString -> IO (Either Int Handle)
openMemoryBS bs = unsafeUseAsCStringLen bs \(dataPtr, dataLen) ->
  openMemory dataPtr (fromIntegral dataLen)

openMemory :: Ptr CChar -> CInt -> IO (Either Int Handle)
openMemory dataPtr dataLen =
  Foreign.alloca \errorPtr -> do
    oggOpusFile <- op_test_memory dataPtr dataLen errorPtr
    Foreign.peek errorPtr >>= \case
      0 -> do
        op_test_open oggOpusFile >>= \case
          0 ->
            pure $ Right (Handle oggOpusFile)
          err ->
            pure $ Left (fromIntegral err)
      err ->
        pure $ Left (fromIntegral err)

free :: Handle -> IO ()
free (Handle handle) = op_free handle

-- * Information

data Channels
  = Mono
  | Stereo
  deriving (Eq, Ord, Show, Enum, Bounded)

channelCount :: Handle -> Either Int Channels
channelCount (Handle handle) =
  case unsafePerformIO (op_channel_count handle) of
    1 -> Right Mono
    2 -> Right Stereo
    n -> Left (fromIntegral n)

pcmTotal :: Handle -> Int
pcmTotal (Handle handle) =
  fromIntegral $ unsafePerformIO (op_pcm_total handle)

-- * Decoding

data Pcm a = Pcm
  { pcmData     :: ForeignPtr a
  , pcmSize     :: Int
  , pcmTime     :: Double
  , pcmChannels :: Either Int Channels
  }
  deriving (Eq, Show)

decodeInt16 :: Handle -> IO (Pcm Int16)
decodeInt16 h@(Handle handle) = do
  fptr <- Foreign.mallocForeignPtrBytes byteSize
  Foreign.withForeignPtr fptr (go 0) >>= \case
    Left ret ->
      error $ show ret
    Right _samplesDone ->
      pure Pcm
        { pcmData     = fptr
        , pcmSize     = byteSize
        , pcmTime     = fromIntegral hPcmSize / 48000
        , pcmChannels = hPcmChannels
        }

  where
    hPcmChannels = channelCount h
    hPcmSize = pcmTotal h

    byteSize = hPcmSize * numChannels * sampleBytes
    samples = hPcmSize * numChannels

    numChannels = case hPcmChannels of
      Right Mono   -> 1
      Right Stereo -> 2
      Left n       -> n

    sampleBytes = Foreign.sizeOf (undefined :: Int16)

    go samplesRead buf = do
      ret <- op_read
        handle
        buf
        (fromIntegral samples)
        Foreign.nullPtr
      if ret < 0 then
        pure $ Left ret
      else do
        let samplesDone = samplesRead + fromIntegral ret
        if samplesDone < hPcmSize then
          go samplesDone $
            Foreign.plusPtr buf (fromIntegral ret * numChannels * sampleBytes)
        else
          pure $ Right samplesDone

-- * FFI

foreign import ccall "op_free"
  op_free :: Ptr OggOpusFile -> IO ()

foreign import ccall "op_test_memory"
  op_test_memory :: Ptr CChar -> CInt -> Ptr CInt -> IO (Ptr OggOpusFile)

foreign import ccall "op_test_open"
  op_test_open :: Ptr OggOpusFile -> IO CInt

foreign import ccall "op_channel_count"
  op_channel_count :: Ptr OggOpusFile -> IO CInt

foreign import ccall "op_pcm_total"
  op_pcm_total :: Ptr OggOpusFile -> IO Int64

foreign import ccall "op_read"
  op_read
    :: Ptr OggOpusFile -- _of
    -> Ptr Int16       -- _pcm
    -> CInt            -- _buf_size
    -> Ptr CInt        -- _li
    -> IO CInt