X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Sound%2FEsounD%2FController.hs;h=c3818561e826cf6125d5296cbb85107319e6b1c0;hb=HEAD;hp=aa9dabae40c9db883635d3049e37937cb20187b9;hpb=080d77f8aece1d14f71f6fd337f0cda9cdf7d740;p=EsounD.git

diff --git a/Sound/EsounD/Controller.hs b/Sound/EsounD/Controller.hs
index aa9daba..c381856 100644
--- a/Sound/EsounD/Controller.hs
+++ b/Sound/EsounD/Controller.hs
@@ -23,19 +23,39 @@ module Sound.EsounD.Controller
     , loopSample
     , stopSample
     , killSample
+
+    , ServerInfo(..)
+    , FrameType(..)
+    , NumChannels(..)
+    , getServerInfo
+
+    , PlayerInfo(..)
+    , SampleInfo(..)
+    , AllInfo(..)
+    , getAllInfo
+
+    , setStreamPan
+    , setDefaultSamplePan
+
+    , ServerState(..)
+    , getServerState
     )
     where
 import Bindings.EsounD
-import Control.Exception.Peel
+import Control.Exception.Control
 import Control.Monad.IO.Class
-import Control.Monad.IO.Peel
+import Control.Monad.IO.Control
 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 Data.Char
+import qualified Data.StorableVector.Lazy as L
 import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Storable
 import Network
+import Prelude hiding (pi)
 import Prelude.Unicode
 import Sound.EsounD.Internals
 import System.IO.SaferFileHandles.Unsafe
@@ -55,13 +75,13 @@ instance Dup Controller where
                 return co { coCloseH = ch' }
 
 -- | Open an ESD handle for controlling ESD.
-openController ∷ MonadPeelIO pr
+openController ∷ MonadControlIO pr
                ⇒ Maybe HostName -- ^ host to connect to.
                → RegionT s pr (Controller (RegionT s pr))
 openController host
-    = block $
+    = mask_ $
       do s  ← liftIO openSocket
-         ch ← onExit $ sanitizeIOError $ closeSocket' s
+         ch ← onExit $ closeSocket' s
          return Controller {
                       coSocket = s
                     , coCloseH = ch
@@ -95,7 +115,6 @@ lock ∷ ( AncestorRegion pr cr
      → cr ()
 lock co
     = liftIO $
-      sanitizeIOError $
       c'esd_lock (fdToCInt $ coSocket co)
           ≫= failOnError "esd_lock(fd) returned an error" (≤ 0)
           ≫  return ()
@@ -109,7 +128,6 @@ unlock ∷ ( AncestorRegion pr cr
        → cr ()
 unlock co
     = liftIO $
-      sanitizeIOError $
       c'esd_unlock (fdToCInt $ coSocket co)
           ≫= failOnError "esd_unlock(fd) returned an error" (≤ 0)
           ≫  return ()
@@ -123,7 +141,6 @@ standby ∷ ( AncestorRegion pr cr
         → cr ()
 standby co
     = liftIO $
-      sanitizeIOError $
       c'esd_standby (fdToCInt $ coSocket co)
           ≫= failOnError "esd_standby(fd) returned an error" (≤ 0)
           ≫  return ()
@@ -137,7 +154,6 @@ resume ∷ ( AncestorRegion pr cr
        → cr ()
 resume co
     = liftIO $
-      sanitizeIOError $
       c'esd_resume (fdToCInt $ coSocket co)
           ≫= failOnError "esd_resume(fd) returned an error" (≤ 0)
           ≫  return ()
@@ -160,7 +176,7 @@ instance Dup Sample where
 
 class (Frame fr, Channels ch) ⇒ SampleSource fr ch dvec where
     -- | Cache a sample in the server.
-    cacheSample ∷ (MonadPeelIO pr)
+    cacheSample ∷ (MonadControlIO pr)
                 ⇒ Controller (RegionT s pr)
                 → Maybe String  -- ^ name used to identify this sample to
                 → Int           -- ^ sample rate
@@ -169,7 +185,7 @@ class (Frame fr, Channels ch) ⇒ SampleSource fr ch dvec where
 
 instance Frame fr ⇒ SampleSource fr Mono (L.Vector fr) where
     cacheSample co name rate v
-        = block $
+        = mask_ $
           do sa ← createSample
                    co
                    name
@@ -188,13 +204,13 @@ instance Frame fr ⇒ SampleSource fr Mono (L.Vector fr) where
 
 instance Frame fr ⇒ SampleSource fr Stereo (L.Vector fr, L.Vector fr) where
     cacheSample co name rate (l, r)
-        = block $
+        = mask_ $
           do sa ← createSample
                    co
                    name
                    rate
-                   ((⊥) ∷ fr  )
-                   ((⊥) ∷ Mono)
+                   ((⊥) ∷ fr    )
+                   ((⊥) ∷ Stereo)
                    (L.length l)
              _  ← liftIO $
                    sanitizeIOError $
@@ -208,7 +224,7 @@ instance Frame fr ⇒ SampleSource fr Stereo (L.Vector fr, L.Vector fr) where
 createSample ∷ ∀fr ch s pr.
                 ( Frame fr
                 , Channels ch
-                , MonadPeelIO pr
+                , MonadControlIO pr
                 )
              ⇒ Controller (RegionT s pr)
              → Maybe String
@@ -217,10 +233,10 @@ createSample ∷ ∀fr ch s pr.
              → ch
              → Int
              → RegionT s pr (Sample (RegionT s pr))
-createSample co name rate _ _ size
-    = block $
+createSample co name rate _ _ len
+    = mask_ $
       do sid ← liftIO newCache
-         ch  ← onExit $ sanitizeIOError $ deleteCache sid
+         ch  ← onExit $ deleteCache sid
          return Sample {
                       saID     = sid
                     , saCtrl   = co
@@ -232,19 +248,24 @@ createSample co name rate _ _ size
             channelFmt ((⊥) ∷ ch) .|.
             c'ESD_SAMPLE
 
+      sampleSize ∷ Int
+      sampleSize = len
+                   ⋅ frameSize   ((⊥) ∷ fr)
+                   ⋅ numChannels ((⊥) ∷ ch)
+
       newCache ∷ IO CInt
       newCache = withCStrOrNull name $ \namePtr →
                      c'esd_sample_cache
                      (fdToCInt $ coSocket co)
                      fmt
                      (fromIntegral rate)
-                     (fromIntegral size)
+                     (fromIntegral sampleSize)
                      namePtr
                      ≫= failOnError ( printf "esd_sample_cache(%s, %s, %s, %s, %s) returned an error"
                                               (show $ coSocket co)
                                               (show fmt)
                                               (show rate)
-                                              (show size)
+                                              (show sampleSize)
                                               (show name)
                                      ) (< 0)
 
@@ -265,7 +286,6 @@ playSample ∷ ( AncestorRegion pr cr
            → 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)
@@ -281,7 +301,6 @@ loopSample ∷ ( AncestorRegion pr cr
            → 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)
@@ -297,7 +316,6 @@ stopSample ∷ ( AncestorRegion pr cr
            → 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)
@@ -313,10 +331,282 @@ killSample ∷ ( AncestorRegion pr cr
            → 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 ()
+
+data FrameType
+    = Int8 | Int16
+    deriving (Show, Eq)
+
+data NumChannels
+    = Mono | Stereo
+    deriving (Show, Eq)
+
+-- | A data type to represent the server info.
+data ServerInfo
+    = ServerInfo {
+        serverVersion    ∷ !Int
+      , serverFrameType  ∷ !FrameType
+      , serverChannels   ∷ !NumChannels
+      , serverSampleRate ∷ !Int
+      }
+    deriving (Show, Eq)
+
+extractServerInfo ∷ Ptr C'esd_server_info → IO ServerInfo
+extractServerInfo siPtr
+    = do si ← peek siPtr
+         return ServerInfo {
+                      serverVersion
+                        = fromIntegral $ c'esd_server_info'version si
+                    , serverFrameType
+                        = extractFrameType $ c'esd_server_info'format si
+                    , serverChannels
+                        = extractNumChannels $ c'esd_server_info'format si
+                    , serverSampleRate
+                        = fromIntegral $ c'esd_server_info'rate si
+                    }
+
+extractFrameType ∷ C'esd_format_t → FrameType
+extractFrameType fmt
+    | fmt .&. c'ESD_BITS8  ≢ 0 = Int8
+    | fmt .&. c'ESD_BITS16 ≢ 0 = Int16
+    | otherwise                = error ("Unknown format: " ⧺ show fmt)
+
+extractNumChannels ∷ C'esd_format_t → NumChannels
+extractNumChannels fmt
+    | fmt .&. c'ESD_MONO   ≢ 0 = Mono
+    | fmt .&. c'ESD_STEREO ≢ 0 = Stereo
+    | otherwise                = error ("Unknown format: " ⧺ show fmt)
+
+-- | Retrieve server properties.
+getServerInfo ∷ ( AncestorRegion pr cr
+                 , MonadIO cr
+                 )
+              ⇒ Controller pr
+              → cr ServerInfo
+getServerInfo co
+    = liftIO $
+      bracket retrieve dispose extractServerInfo
+    where
+      retrieve ∷ IO (Ptr C'esd_server_info)
+      retrieve = c'esd_get_server_info (fdToCInt $ coSocket co)
+                 ≫= failOnError "esd_get_server_info(fd) returned an error" (≡ nullPtr)
+
+      dispose ∷ Ptr C'esd_server_info → IO ()
+      dispose = c'esd_free_server_info
+
+-- | A data type to represent a player stream info.
+data PlayerInfo
+    = PlayerInfo {
+        playerID               ∷ !Int
+      , playerName             ∷ !String
+      , playerSampleRate       ∷ !Int
+      , playerFrameType        ∷ !FrameType
+      , playerChannels         ∷ !NumChannels
+      , playerLeftVolumeScale  ∷ !Double -- ^ 0 <= scale <= 1
+      , playerRightVolumeScale ∷ !Double -- ^ 0 <= scale <= 1
+      }
+    deriving (Show, Eq)
+
+extractPlayerInfo ∷ Ptr C'esd_player_info → IO [PlayerInfo]
+extractPlayerInfo piPtr
+    | piPtr ≡ nullPtr = return []
+    | otherwise
+        = do pi ← peek piPtr
+             let next = c'esd_player_info'next pi
+                 pi'  = PlayerInfo {
+                          playerID
+                            = fromIntegral $ c'esd_player_info'source_id pi
+                        , playerName
+                            = map (chr ∘ fromIntegral) $ c'esd_player_info'name pi
+                        , playerSampleRate
+                            = fromIntegral $ c'esd_player_info'rate pi
+                        , playerFrameType
+                            = extractFrameType $ c'esd_player_info'format pi
+                        , playerChannels
+                            = extractNumChannels $ c'esd_player_info'format pi
+                        , playerLeftVolumeScale
+                            = (fromIntegral $ c'esd_player_info'left_vol_scale pi)
+                              ÷
+                              c'ESD_VOLUME_BASE
+                        , playerRightVolumeScale
+                            = (fromIntegral $ c'esd_player_info'right_vol_scale pi)
+                              ÷
+                              c'ESD_VOLUME_BASE
+                        }
+             pi'' ← extractPlayerInfo next
+             return (pi' : pi'')
+
+-- | A data type to represent a cached sample info.
+data SampleInfo
+    = SampleInfo {
+        sampleID               ∷ !Int
+      , sampleName             ∷ !String
+      , sampleSampleRate       ∷ !Int
+      , sampleFrameType        ∷ !FrameType
+      , sampleChannels         ∷ !NumChannels
+      , sampleLength           ∷ !Int
+      , sampleLeftVolumeScale  ∷ !Double -- ^ 0 <= scale <= 1
+      , sampleRightVolumeScale ∷ !Double -- ^ 0 <= scale <= 1
+      }
+    deriving (Show, Eq)
+
+extractSampleLength ∷ FrameType → NumChannels → Int → Int
+extractSampleLength fr ch bufLen
+    = bufLen
+      `div`
+      case fr of
+        Int8  → 1
+        Int16 → 2
+      `div`
+      case ch of
+        Mono   → 1
+        Stereo → 2
+
+extractSampleInfo ∷ Ptr C'esd_sample_info → IO [SampleInfo]
+extractSampleInfo piPtr
+    | piPtr ≡ nullPtr = return []
+    | otherwise
+        = do pi ← peek piPtr
+             let next = c'esd_sample_info'next pi
+                 fr   = extractFrameType $ c'esd_sample_info'format pi
+                 ch   = extractNumChannels $ c'esd_sample_info'format pi
+                 pi'  = SampleInfo {
+                          sampleID
+                            = fromIntegral $ c'esd_sample_info'sample_id pi
+                        , sampleName
+                            = map (chr ∘ fromIntegral) $ c'esd_sample_info'name pi
+                        , sampleSampleRate
+                            = fromIntegral $ c'esd_sample_info'rate pi
+                        , sampleFrameType
+                            = fr
+                        , sampleChannels
+                            = ch
+                        , sampleLength
+                            = extractSampleLength fr ch $
+                              fromIntegral $ c'esd_sample_info'length pi
+                        , sampleLeftVolumeScale
+                            = (fromIntegral $ c'esd_sample_info'left_vol_scale pi)
+                              ÷
+                              c'ESD_VOLUME_BASE
+                        , sampleRightVolumeScale
+                            = (fromIntegral $ c'esd_sample_info'right_vol_scale pi)
+                              ÷
+                              c'ESD_VOLUME_BASE
+                        }
+             pi'' ← extractSampleInfo next
+             return (pi' : pi'')
+
+-- | A data type to represent all info in the ESD server.
+data AllInfo
+    = AllInfo {
+        serverInfo  ∷ !ServerInfo
+      , playersInfo ∷ ![PlayerInfo]
+      , samplesInfo ∷ ![SampleInfo]
+      }
+    deriving (Show, Eq)
+
+extractAllInfo ∷ Ptr C'esd_info → IO AllInfo
+extractAllInfo eiPtr
+    = do ei  ← peek eiPtr
+         srv ← extractServerInfo $ c'esd_info'server      ei
+         pis ← extractPlayerInfo $ c'esd_info'player_list ei
+         sis ← extractSampleInfo $ c'esd_info'sample_list ei
+         return AllInfo {
+                      serverInfo  = srv
+                    , playersInfo = pis
+                    , samplesInfo = sis
+                    }
+
+-- | Retrieve all info in the ESD server.
+getAllInfo ∷ ( AncestorRegion pr cr
+              , MonadIO cr
+              )
+           ⇒ Controller pr
+           → cr AllInfo
+getAllInfo co
+    = liftIO $
+      bracket retrieve dispose extractAllInfo
+    where
+      retrieve ∷ IO (Ptr C'esd_info)
+      retrieve = c'esd_get_all_info (fdToCInt $ coSocket co)
+                 ≫= failOnError "esd_get_all_info(fd) returned an error" (≡ nullPtr)
+
+      dispose ∷ Ptr C'esd_info → IO ()
+      dispose = c'esd_free_all_info
+
+-- | Reset the volume panning for a stream.
+setStreamPan ∷ ( AncestorRegion pr cr
+                , MonadIO cr
+                )
+             ⇒ Controller pr
+             → Int    -- ^ Stream ID
+             → Double -- ^ left volume: 0 <= scale <= 1
+             → Double -- ^ right volume: 0 <= scale <= 1
+             → cr ()
+setStreamPan co sid l r
+    = liftIO $
+      c'esd_set_stream_pan (fdToCInt $ coSocket co)
+                           (fromIntegral sid)
+                           (floor $ l ⋅ c'ESD_VOLUME_BASE)
+                           (floor $ r ⋅ c'ESD_VOLUME_BASE)
+          ≫= failOnError ( printf "esd_set_stream_pan(%s, %s, %s, %s) returned an error"
+                                   (show $ coSocket co)
+                                   (show sid)
+                                   (show l  )
+                                   (show r  )
+                          ) (≤ 0)
+          ≫  return ()
+
+-- | Reset the default volume panning for a sample.
+setDefaultSamplePan ∷ ( AncestorRegion pr cr
+                       , MonadIO cr
+                       )
+                    ⇒ Controller pr
+                    → Int    -- ^ Sample ID
+                    → Double -- ^ left volume: 0 <= scale <= 1
+                    → Double -- ^ right volume: 0 <= scale <= 1
+                    → cr ()
+setDefaultSamplePan co sid l r
+    = liftIO $
+      c'esd_set_default_sample_pan (fdToCInt $ coSocket co)
+                                   (fromIntegral sid)
+                                   (floor $ l ⋅ c'ESD_VOLUME_BASE)
+                                   (floor $ r ⋅ c'ESD_VOLUME_BASE)
+          ≫= failOnError ( printf "esd_set_default_sample_pan(%s, %s, %s, %s) returned an error"
+                                   (show $ coSocket co)
+                                   (show sid)
+                                   (show l  )
+                                   (show r  )
+                          ) (≤ 0)
+          ≫  return ()
+
+-- | A data type to represent server's state.
+data ServerState
+    = Standby
+    | AutoStandby
+    | Running
+    deriving (Eq, Show)
+
+extractServerState ∷ C'esd_standby_mode_t → ServerState
+extractServerState st
+    | st ≡ c'ESM_ON_STANDBY     = Standby
+    | st ≡ c'ESM_ON_AUTOSTANDBY = AutoStandby
+    | st ≡ c'ESM_RUNNING        = Running
+    | otherwise                  = error ("unknown state: " ⧺ show st)
+
+-- | Retrieve the server's state.
+getServerState ∷ ( AncestorRegion pr cr
+                  , MonadIO cr
+                  )
+               ⇒ Controller pr
+               → cr ServerState
+getServerState co
+    = liftIO $
+      fmap extractServerState $
+      c'esd_get_standby_mode (fdToCInt $ coSocket co)
+          ≫= failOnError "esd_get_standby_mode(fd) returned an error" (≡ c'ESM_ERROR)