{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, ScopedTypeVariables,
             DeriveDataTypeable #-}
-- | High level API for decoding Ogg-Vorbis files or streams.
-- This module is intended to be imported qualified, e.g.
--
-- > import qualified Codec.Audio.Vorbis.File as V
module Codec.Audio.Vorbis.File (
        -- * Opening file or streams
        openFile,
        openCallbacks,
        withFile,
        withCallbacks,
        File,
        -- * File metadata
        info,
        Info(..),
        Channels(..),
        -- * Read data from file
        read,
        Endianness(..),
        getSystemEndianness,
        WordSize(..),
        Signedness(..),
        -- * Close file
        close
    ) where

import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Internal as B
import Control.Exception
import Data.Int
import Data.Typeable
import Foreign hiding (new)
import Foreign.C
import Prelude hiding (catch, read)
import System.IO (SeekMode(..), hClose, hSeek, hTell, IOMode(..))
import qualified System.IO as IO
import System.Endian

#include <vorbis/vorbisfile.h>
#include <stdlib.h>

type ReadFunc = Ptr Word8 -> CSize -> CSize -> Ptr () -> IO CSize
type SeekFunc = Ptr () -> Int64 -> CInt -> IO CInt
type CloseFunc = Ptr () -> IO CInt
type TellFunc  = Ptr () -> IO CLong

foreign import ccall safe "new_OggVorbis_File" new_OggVorbis_File
    :: FunPtr ReadFunc -> FunPtr SeekFunc -> FunPtr CloseFunc -> FunPtr TellFunc -> Ptr CInt -> IO (Ptr File_struct)

foreign import ccall "free_OggVorbis_File" free_OggVorbis_File
    :: Ptr File_struct -> IO ()

foreign import ccall "wrapper" mkReadFunc
    :: ReadFunc -> IO (FunPtr ReadFunc)

foreign import ccall "wrapper" mkSeekFunc
    :: SeekFunc -> IO (FunPtr SeekFunc)

foreign import ccall "wrapper" mkCloseFunc
    :: CloseFunc -> IO (FunPtr CloseFunc)

foreign import ccall "wrapper" mkTellFunc
    :: TellFunc -> IO (FunPtr TellFunc)

foreign import ccall safe "info_OggVorbis_File" info_OggVorbis_File
    :: Ptr File_struct -> Ptr CInt -> Ptr CInt -> Ptr CLong -> IO CInt

foreign import ccall safe "ov_read" ov_read
    :: Ptr File_struct -> Ptr CChar -> CInt -> CInt -> CInt -> CInt -> Ptr CInt -> IO CLong

data File_struct
data File = File (Ptr File_struct) (FunPtr ReadFunc) (FunPtr CloseFunc) (FunPtr SeekFunc) (FunPtr TellFunc)

data OggVorbisStatus =
      OV_EREAD
    | OV_EFAULT
    | OV_EIMPL
    | OV_EINVAL
    | OV_ENOTVORBIS
    | OV_EBADHEADER
    | OV_EVERSION
    | OV_ENOTAUDIO
    | OV_EBADPACKET
    | OV_EBADLINK
    | OV_ENOSEEK
    | OV_BADINFO         -- Ours
    deriving (Eq, Show)

data OggVorbisException = OggVorbisException OggVorbisStatus
    deriving (Eq, Show, Typeable)

instance Exception OggVorbisException where

throwVorbisError :: CInt -> IO a
throwVorbisError err = do
    let status = case err of
            (#const OV_EREAD)      -> OV_EREAD
            (#const OV_EFAULT)     -> OV_EFAULT
            (#const OV_EIMPL)      -> OV_EIMPL
            (#const OV_EINVAL)     -> OV_EINVAL
            (#const OV_ENOTVORBIS) -> OV_ENOTVORBIS
            (#const OV_EBADHEADER) -> OV_EBADHEADER
            (#const OV_EVERSION)   -> OV_EVERSION
            (#const OV_ENOTAUDIO)  -> OV_ENOTAUDIO
            (#const OV_EBADPACKET) -> OV_EBADPACKET
            (#const OV_EBADLINK)   -> OV_EBADLINK
            (#const OV_ENOSEEK)    -> OV_ENOSEEK
            _                      -> error $ "Codec.Audio.Vorbis.File.throwVorbisError: bad error: "++show err
    throwIO $ OggVorbisException status

-- | Open the specified Ogg-Vorbis file for decoding.
openFile :: FilePath -> IO File
openFile path = do
    h <- IO.openFile path ReadMode
    let readFunc size nmemb = B.hGet h (size * nmemb)
        closeFunc = hClose h
        seekFunc = hSeek h
        tellFunc = hTell h
    openCallbacks readFunc closeFunc (Just (seekFunc, tellFunc))

-- | Decode Ogg-Vorbis using the specified callbacks to do the back-end I/O.
-- Seek and tell functions are optional.
openCallbacks :: (Int -> Int -> IO ByteString)    -- ^ Read function, taking size and nmemb
              -> IO ()                            -- ^ Close function
              -> Maybe (SeekMode -> Integer -> IO (), IO Integer)  -- ^ Seek and tell functions
              -> IO File
openCallbacks readFunc closeFunc mSeekTell = do
    c_readFunc <- mkReadFunc $ \buf size nmemb _ -> do
        r <- readFunc (fromIntegral size) (fromIntegral nmemb)
        B.unsafeUseAsCStringLen r $ \(rbuf, rlen) -> B.memcpy (castPtr buf) (castPtr rbuf) rlen
        return $ fromIntegral (B.length r) `div` size
      `catch` \(_ :: IOException) ->
        return (-1)
    c_closeFunc <- mkCloseFunc $ \_ -> do
        closeFunc
        return 0
      `catch` \(_ :: IOException) ->
        return (-1)
    (c_seekFunc, c_tellFunc) <- case mSeekTell of
        Just (seekFunc, tellFunc) -> do
            c_seekFunc <- mkSeekFunc $ \_ offset whence -> do
                let mode = case whence of
                        (#const SEEK_SET) -> AbsoluteSeek
                        (#const SEEK_CUR) -> RelativeSeek
                        (#const SEEK_END) -> SeekFromEnd
                        _                 -> error $ "Codec.Audio.Vorbis.File.new: bad whence in seek: "++show whence
                seekFunc mode (fromIntegral offset)
                return 0
              `catch` \(_ :: IOException) ->
                return (-1)
            c_tellFunc <- mkTellFunc $ \_ -> do
                fromIntegral <$> tellFunc
              `catch` \(_ :: IOException) ->
                return (-1)
            return (c_seekFunc, c_tellFunc)
        Nothing -> return (nullFunPtr, nullFunPtr)
    alloca $ \p_error -> do
        f <- new_OggVorbis_File c_readFunc c_seekFunc c_closeFunc c_tellFunc p_error
        if f /= nullPtr then
            return $ File f c_readFunc c_closeFunc c_seekFunc c_tellFunc
          else do
            freeFunPtrs c_readFunc c_closeFunc c_seekFunc c_tellFunc
            err <- peek p_error
            throwVorbisError err

-- | Close the file once we've finished with it. Must be used with the handles returned
-- by 'openFile' and 'openCallbacks'.
close :: File -> IO ()
close (File c_f c_readFunc c_closeFunc c_seekFunc c_tellFunc) = do
    free_OggVorbis_File c_f
    freeFunPtrs c_readFunc c_closeFunc c_seekFunc c_tellFunc

freeFunPtrs :: FunPtr ReadFunc -> FunPtr CloseFunc -> FunPtr SeekFunc -> FunPtr TellFunc -> IO ()
freeFunPtrs c_readFunc c_seekFunc c_closeFunc c_tellFunc = do
    when (c_seekFunc /= nullFunPtr) $ freeHaskellFunPtr c_seekFunc
    when (c_tellFunc /= nullFunPtr) $ freeHaskellFunPtr c_tellFunc
    freeHaskellFunPtr c_readFunc
    freeHaskellFunPtr c_closeFunc

-- | Open the specified Ogg-Vorbis file for decoding.
--
-- Opens it using the loan pattern: Guaranteed to call 'close' for you on
-- completion (exception safe), so you must not call 'close' explicitly.
withFile :: FilePath -> (File -> IO a) -> IO a
withFile path code = bracket (openFile path) close code

-- | Decode Ogg-Vorbis using the specified callbacks to do the back-end I/O.
-- Seek and tell functions are optional.
--
-- Opens it using the loan pattern: Guaranteed to call 'close' for you on
-- completion (exception safe), so you must not call 'close' explicitly.
withCallbacks :: (Int -> Int -> IO ByteString)    -- ^ Read function, taking size and nmemb
              -> IO ()                            -- ^ Close function
              -> Maybe (SeekMode -> Integer -> IO (), IO Integer)  -- ^ Seek and tell functions
              -> (File -> IO a)
              -> IO a
withCallbacks r c mST code = bracket (openCallbacks r c mST) close code

data Info = Info {
        inVersion  :: Int,
        inChannels :: Channels,
        inRate     :: Int
    }
    deriving Show

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

info :: File -> IO Info
info (File c_f _ _ _ _) =
    alloca $ \p_version ->
    alloca $ \p_channels ->
    alloca $ \p_rate -> do
        ret <- info_OggVorbis_File c_f p_version p_channels p_rate
        if ret == 0 then
            Info <$> (fromIntegral <$> peek p_version)
                 <*> (unmarshallChannels <$> peek p_channels)
                 <*> (fromIntegral <$> peek p_rate)
          else do
            throwIO $ OggVorbisException OV_BADINFO
  where
    unmarshallChannels 1 = Mono
    unmarshallChannels 2 = Stereo
    unmarshallChannels c = error $ "Codec.Audio.Vorbis.info: can't unmarshall no. of channels: "++show c

data Signedness = Signed | Unsigned deriving (Eq, Ord, Show)
data WordSize = EightBit | SixteenBit deriving (Eq, Ord, Show)

-- | Read data from the file. Returns the data block and the number of the current
-- logical bitstream. 'Nothing' for end of file.
read :: File
     -> Int          -- ^ Maximum bytes to read (will typically return less than this)
     -> Endianness   -- ^ How to encode the samples as bytes
     -> WordSize     -- ^ Desired word size
     -> Signedness   -- ^ Whether you want signed or unsigned values
     -> IO (Maybe (ByteString, Int)) 
read (File f _ _ _ _) bytes endianness wordsize signedness =
    allocaBytes bytes $ \buf ->
    alloca $ \p_bitstream -> go buf p_bitstream
  where
    go buf p_bitstream = do
        ret <- ov_read f buf (fromIntegral bytes) c_endianness c_wordsize c_signedness p_bitstream
        case ret of
            -- Deal with hole by just continuing to read. We might want to improve this
            -- in future.
            (#const OV_HOLE) -> go buf p_bitstream
            0 -> return Nothing
            n | n > 0 -> do
                bs <- B.create (fromIntegral n) (\bs_buf -> B.memcpy bs_buf (castPtr buf) (fromIntegral n))
                bitstream <- fromIntegral <$> peek p_bitstream
                return $ Just (bs, bitstream)
            _ -> throwVorbisError (fromIntegral ret)
    c_endianness = case endianness of
        LittleEndian -> 0
        BigEndian    -> 1
    c_wordsize = case wordsize of
        EightBit     -> 1
        SixteenBit   -> 2
    c_signedness = case signedness of
        Unsigned     -> 0
        Signed       -> 1