{-# LANGUAGE
    FlexibleContexts
  , FlexibleInstances
  , KindSignatures
  , MultiParamTypeClasses
  , UnicodeSyntax
  , ScopedTypeVariables
  #-}
-- | EsounD controlling handles.
module Sound.EsounD.Controller
    ( Controller
    , openController

    , lock
    , unlock

    , standby
    , resume

    , Sample
    , SampleSource(..)
    , playSample
    , loopSample
    , stopSample
    , killSample

    , ServerInfo(..)
    , FrameType(..)
    , NumChannels(..)
    , getServerInfo
    )
    where
import Bindings.EsounD
import Control.Exception.Peel
import Control.Monad.IO.Class
import Control.Monad.IO.Peel
import Control.Monad.Trans.Region
import Control.Monad.Trans.Region.OnExit
import Control.Monad.Unicode
import Data.Bits
import Data.StorableVector.Lazy as L
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import Network
import Prelude.Unicode
import Sound.EsounD.Internals
import System.IO.SaferFileHandles.Unsafe
import System.Posix.IO hiding (dup)
import System.Posix.Types
import Text.Printf

-- ^ An opaque ESD handle for controlling ESD.
data Controller (r ∷ ★ → ★)
    = Controller {
        coSocket ∷ !Fd
      , coCloseH ∷ !(FinalizerHandle r)
      }

instance Dup Controller where
    dup co = do ch' ← dup (coCloseH co)
                return co { coCloseH = ch' }

-- | Open an ESD handle for controlling ESD.
openController ∷ MonadPeelIO pr
               ⇒ Maybe HostName -- ^ host to connect to.
               → RegionT s pr (Controller (RegionT s pr))
openController host
    = block $
      do s  ← liftIO openSocket
         ch ← onExit $ sanitizeIOError $ closeSocket' s
         return Controller {
                      coSocket = s
                    , coCloseH = ch
                    }
    where
      openSocket ∷ IO Fd
      openSocket = withCStrOrNull host $ \hostPtr →
                       c'esd_open_sound hostPtr
                       ≫= wrapSocket'

      wrapSocket' ∷ Monad m ⇒ CInt → m Fd
      wrapSocket' (-1) = fail ( printf "esd_open_sound(%s) returned an error"
                                       (show host)
                              )
      wrapSocket' fd   = return $ Fd fd

      closeSocket' ∷ Fd → IO ()
      closeSocket' fd
          = do _ ← c'esd_close $ fdToCInt fd
               return ()

fdToCInt ∷ Fd → CInt
fdToCInt (Fd fd) = fromIntegral fd

-- | Lock the ESD so that it won't accept connections from remote
-- hosts.
lock ∷ ( AncestorRegion pr cr
        , MonadIO cr
        )
     ⇒ Controller pr
     → cr ()
lock co
    = liftIO $
      sanitizeIOError $
      c'esd_lock (fdToCInt $ coSocket co)
          ≫= failOnError "esd_lock(fd) returned an error" (≤ 0)
          ≫  return ()

-- | Unlock the ESD so that it will accept connections from remote
-- hosts.
unlock ∷ ( AncestorRegion pr cr
          , MonadIO cr
          )
       ⇒ Controller pr
       → cr ()
unlock co
    = liftIO $
      sanitizeIOError $
      c'esd_unlock (fdToCInt $ coSocket co)
          ≫= failOnError "esd_unlock(fd) returned an error" (≤ 0)
          ≫  return ()

-- | Let ESD stop playing sounds and release its connection to the
-- audio device so that other processes may use it.
standby ∷ ( AncestorRegion pr cr
           , MonadIO cr
           )
        ⇒ Controller pr
        → cr ()
standby co
    = liftIO $
      sanitizeIOError $
      c'esd_standby (fdToCInt $ coSocket co)
          ≫= failOnError "esd_standby(fd) returned an error" (≤ 0)
          ≫  return ()

-- | Let ESD attempt to reconnect to the audio device and start
-- playing sounds again.
resume ∷ ( AncestorRegion pr cr
          , MonadIO cr
          )
       ⇒ Controller pr
       → cr ()
resume co
    = liftIO $
      sanitizeIOError $
      c'esd_resume (fdToCInt $ coSocket co)
          ≫= failOnError "esd_resume(fd) returned an error" (≤ 0)
          ≫  return ()

-- | An opaque ESD sample handle.
data Sample (r ∷ ★ → ★)
    = Sample {
        saID     ∷ !CInt
      , saCtrl   ∷ !(Controller r)
      , saCloseH ∷ !(FinalizerHandle r)
      }

instance Dup Sample where
    dup sa = do ctrl' ← dup (saCtrl   sa)
                ch'   ← dup (saCloseH sa)
                return sa {
                         saCtrl   = ctrl'
                       , saCloseH = ch'
                       }

class (Frame fr, Channels ch) ⇒ SampleSource fr ch dvec where
    -- | Cache a sample in the server.
    cacheSample ∷ (MonadPeelIO pr)
                ⇒ Controller (RegionT s pr)
                → Maybe String  -- ^ name used to identify this sample to
                → Int           -- ^ sample rate
                → dvec          -- ^ frames in deinterleaved vectors
                → RegionT s pr (Sample (RegionT s pr))

instance Frame fr ⇒ SampleSource fr Mono (L.Vector fr) where
    cacheSample co name rate v
        = block $
          do sa ← createSample
                   co
                   name
                   rate
                   ((⊥) ∷ fr  )
                   ((⊥) ∷ Mono)
                   (L.length v)
             _  ← liftIO $
                   sanitizeIOError $
                   do h       ← fdToHandle $ coSocket co
                      _       ← L.hPut h v
                      (Fd fd) ← handleToFd h
                      c'esd_confirm_sample_cache fd
                          ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
             return sa

instance Frame fr ⇒ SampleSource fr Stereo (L.Vector fr, L.Vector fr) where
    cacheSample co name rate (l, r)
        = block $
          do sa ← createSample
                   co
                   name
                   rate
                   ((⊥) ∷ fr    )
                   ((⊥) ∷ Stereo)
                   (L.length l)
             _  ← liftIO $
                   sanitizeIOError $
                   do h       ← fdToHandle $ coSocket co
                      _       ← L.hPut h (interleave l r)
                      (Fd fd) ← handleToFd h
                      c'esd_confirm_sample_cache fd
                          ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
             return sa

createSample ∷ ∀fr ch s pr.
                ( Frame fr
                , Channels ch
                , MonadPeelIO pr
                )
             ⇒ Controller (RegionT s pr)
             → Maybe String
             → Int
             → fr
             → ch
             → Int
             → RegionT s pr (Sample (RegionT s pr))
createSample co name rate _ _ size
    = block $
      do sid ← liftIO newCache
         ch  ← onExit $ sanitizeIOError $ deleteCache sid
         return Sample {
                      saID     = sid
                    , saCtrl   = co
                    , saCloseH = ch
                    }
    where
      fmt ∷ C'esd_format_t
      fmt = frameFmt   ((⊥) ∷ fr) .|.
            channelFmt ((⊥) ∷ ch) .|.
            c'ESD_SAMPLE

      newCache ∷ IO CInt
      newCache = withCStrOrNull name $ \namePtr →
                     c'esd_sample_cache
                     (fdToCInt $ coSocket co)
                     fmt
                     (fromIntegral rate)
                     (fromIntegral size)
                     namePtr
                     ≫= failOnError ( printf "esd_sample_cache(%s, %s, %s, %s, %s) returned an error"
                                              (show $ coSocket co)
                                              (show fmt)
                                              (show rate)
                                              (show size)
                                              (show name)
                                     ) (< 0)

      deleteCache ∷ CInt → IO ()
      deleteCache sid
          = c'esd_sample_free (fdToCInt $ coSocket co) sid
            ≫= failOnError ( printf "esd_sample_free(%s) returned an error"
                                     (show $ coSocket co)
                                     (show sid)
                            ) (< 0)
            ≫  return ()

-- | Play a cached sample once.
playSample ∷ ( AncestorRegion pr cr
              , MonadIO cr
              )
           ⇒ Sample pr
           → cr ()
playSample sa
    = liftIO $
      sanitizeIOError $
      c'esd_sample_play (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
          ≫= failOnError ( printf "esd_sample_play(%s, %s) returned an error"
                                   (show $ coSocket $ saCtrl sa)
                                   (show $ saID sa)
                          ) (≤ 0)
          ≫  return ()

-- | Play a cached sample repeatedly.
loopSample ∷ ( AncestorRegion pr cr
              , MonadIO cr
              )
           ⇒ Sample pr
           → cr ()
loopSample sa
    = liftIO $
      sanitizeIOError $
      c'esd_sample_loop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
          ≫= failOnError ( printf "esd_sample_loop(%s, %s) returned an error"
                                   (show $ coSocket $ saCtrl sa)
                                   (show $ saID sa)
                          ) (≤ 0)
          ≫  return ()

-- | Stop a looping sample at end.
stopSample ∷ ( AncestorRegion pr cr
              , MonadIO cr
              )
           ⇒ Sample pr
           → cr ()
stopSample sa
    = liftIO $
      sanitizeIOError $
      c'esd_sample_stop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
          ≫= failOnError ( printf "esd_sample_stop(%s, %s) returned an error"
                                   (show $ coSocket $ saCtrl sa)
                                   (show $ saID sa)
                          ) (≤ 0)
          ≫  return ()

-- | Stop a playing sample immediately.
killSample ∷ ( AncestorRegion pr cr
              , MonadIO cr
              )
           ⇒ Sample pr
           → cr ()
killSample sa
    = liftIO $
      sanitizeIOError $
      c'esd_sample_kill (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
          ≫= failOnError ( printf "esd_sample_kill(%s, %s) returned an error"
                                   (show $ coSocket $ saCtrl sa)
                                   (show $ saID sa)
                          ) (≤ 0)
          ≫  return ()



-- | A data type to represent the server info.
data ServerInfo
    = ServerInfo {
        serverVersion    ∷ !Int
      , serverFrameType  ∷ !FrameType
      , serverChannels   ∷ !NumChannels
      , serverSampleRate ∷ !Int
      }
    deriving (Show, Eq)

data FrameType
    = Int8 | Int16
    deriving (Show, Eq)

data NumChannels
    = Mono | Stereo
    deriving (Show, Eq)

-- | Retrieve server properties.
getServerInfo ∷ ( AncestorRegion pr cr
                 , MonadIO cr
                 )
              ⇒ Controller pr
              → cr ServerInfo
getServerInfo co
    = liftIO $
      sanitizeIOError $
      bracket retrieve dispose extract
    where
      retrieve ∷ IO (Ptr C'esd_server_info)
      retrieve = do siPtr ← c'esd_get_server_info (fdToCInt $ coSocket co)
                    if siPtr ≡ nullPtr then
                        fail "esd_resume(fd) returned an error"
                      else
                        return siPtr

      dispose ∷ Ptr C'esd_server_info → IO ()
      dispose = c'esd_free_server_info

      extract ∷ Ptr C'esd_server_info → IO ServerInfo
      extract siPtr
          = do si ← peek siPtr
               return ServerInfo {
                            serverVersion
                                = fromIntegral $
                                  c'esd_server_info'version si
                          , serverFrameType
                              = case c'esd_server_info'format si of
                                  fmt | fmt .&. c'ESD_BITS8  ≡ 1 → Int8
                                      | fmt .&. c'ESD_BITS16 ≡ 1 → Int16
                                      | otherwise                 →  error ("Unknown format: " ⧺ show fmt)
                          , serverChannels
                              = case c'esd_server_info'format si of
                                  fmt | fmt .&. c'ESD_MONO   ≡ 1 → Mono
                                      | fmt .&. c'ESD_STEREO ≡ 1 → Stereo
                                      | otherwise                 → error ("Unknown format: " ⧺ show fmt)
                          , serverSampleRate
                              = fromIntegral $
                                c'esd_server_info'rate si
                          }