keid-sound-openal-0.1.1.0: src/Resource/Opus.hs

module Resource.Opus
  ( Config(..)
  , Source
  , load
  , loadPCM
  ) where

import RIO

import Foreign qualified
import Foreign.C.Types (CFloat(..))
import GHC.Stack (withFrozenCallStack)
import Sound.OpenAL qualified as OpenAL
import Sound.OpusFile qualified as OpusFile

import Resource.Source qualified as Resource

data Config = Config
  { gain        :: Float
  , loopingMode :: Bool
  , byteSource  :: Resource.Source
  }

type Source = (Double, OpenAL.Source)

load
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , HasCallStack
     )
  => OpenAL.Device
  -> Config
  -> m Source
load _device Config{..} = do
  pcm <- withFrozenCallStack $
    Resource.load loadPCM byteSource

  alFormat <-
    case OpusFile.pcmChannels pcm of
      Right OpusFile.Stereo ->
        pure OpenAL.Stereo16
      Right OpusFile.Mono ->
        pure OpenAL.Mono16
      Left n -> do
        logError $ mconcat
          [ "unexpected channels in "
          , displayShow byteSource
          , ": "
          , displayShow n
          ]
        exitFailure

  !buffer <- liftIO OpenAL.genObjectName
  liftIO $
    Foreign.withForeignPtr (OpusFile.pcmData pcm) \ptr -> do
      let
        mreg =
          OpenAL.MemoryRegion ptr (fromIntegral $ OpusFile.pcmSize pcm)
      OpenAL.bufferData buffer OpenAL.$=! OpenAL.BufferData mreg alFormat 48000

  !source <- liftIO $ OpenAL.genObjectName
  liftIO do
    OpenAL.buffer source OpenAL.$=! Just buffer
    OpenAL.loopingMode source OpenAL.$=! loopingMode'
    OpenAL.sourceGain source OpenAL.$=! gain'
    OpenAL.rolloffFactor source OpenAL.$=! 0 -- XXX: exempt from distance attenuation

  pure (OpusFile.pcmTime pcm, source)
  where
    loopingMode' =
      if loopingMode then
        OpenAL.Looping
      else
        OpenAL.OneShot
    gain' = CFloat gain

-- TODO: extract to `opusfile`
loadPCM :: MonadIO m => ByteString -> m (OpusFile.Pcm Int16)
loadPCM bytes = do
  !opusBytes <- liftIO $
    OpusFile.openMemoryBS bytes >>= \case
      Left err ->
        throwString $ "Opus loader error: " <> show err
      Right res ->
        pure res
  !pcmInt16 <- liftIO $ OpusFile.decodeInt16 opusBytes
  liftIO $ OpusFile.free opusBytes
  pure pcmInt16