Sound/EsounD/Controller.hs

   1 {-# LANGUAGE
   2     FlexibleContexts
   3   , FlexibleInstances
   4   , KindSignatures
   5   , MultiParamTypeClasses
   6   , UnicodeSyntax
   7   , ScopedTypeVariables
   8   #-}
   9 -- | EsounD controlling handles.
  10 module Sound.EsounD.Controller
  11     ( Controller
  12     , openController
  13
  14     , lock
  15     , unlock
  16
  17     , standby
  18     , resume
  19
  20     , Sample
  21     , SampleSource(..)
  22     , playSample
  23     , loopSample
  24     , stopSample
  25     , killSample
  26
  27     , ServerInfo(..)
  28     , FrameType(..)
  29     , NumChannels(..)
  30     , getServerInfo
  31
  32     , PlayerInfo(..)
  33     , SampleInfo(..)
  34     , AllInfo(..)
  35     , getAllInfo
  36
  37     , setStreamPan
  38     , setDefaultSamplePan
  39
  40     , ServerState(..)
  41     , getServerState
  42     )
  43     where
  44 import Bindings.EsounD
  45 import Control.Exception.Control
  46 import Control.Monad.IO.Class
  47 import Control.Monad.IO.Control
  48 import Control.Monad.Trans.Region
  49 import Control.Monad.Trans.Region.OnExit
  50 import Control.Monad.Unicode
  51 import Data.Bits
  52 import Data.Char
  53 import qualified Data.StorableVector.Lazy as L
  54 import Foreign.C.Types
  55 import Foreign.Ptr
  56 import Foreign.Storable
  57 import Network
  58 import Prelude hiding (pi)
  59 import Prelude.Unicode
  60 import Sound.EsounD.Internals
  61 import System.IO.SaferFileHandles.Unsafe
  62 import System.Posix.IO hiding (dup)
  63 import System.Posix.Types
  64 import Text.Printf
  65
  66 -- ^ An opaque ESD handle for controlling ESD.
  67 data Controller (r ∷ ★ → ★)
  68     = Controller {
  69         coSocket ∷ !Fd
  70       , coCloseH ∷ !(FinalizerHandle r)
  71       }
  72
  73 instance Dup Controller where
  74     dup co = do ch' ← dup (coCloseH co)
  75                 return co { coCloseH = ch' }
  76
  77 -- | Open an ESD handle for controlling ESD.
  78 openController ∷ MonadControlIO pr
  79                ⇒ Maybe HostName -- ^ host to connect to.
  80                → RegionT s pr (Controller (RegionT s pr))
  81 openController host
  82     = mask_ $
  83       do s  ← liftIO openSocket
  84          ch ← onExit $ closeSocket' s
  85          return Controller {
  86                       coSocket = s
  87                     , coCloseH = ch
  88                     }
  89     where
  90       openSocket ∷ IO Fd
  91       openSocket = withCStrOrNull host $ \hostPtr →
  92                        c'esd_open_sound hostPtr
  93                        ≫= wrapSocket'
  94
  95       wrapSocket' ∷ Monad m ⇒ CInt → m Fd
  96       wrapSocket' (-1) = fail ( printf "esd_open_sound(%s) returned an error"
  97                                        (show host)
  98                               )
  99       wrapSocket' fd   = return $ Fd fd
 100
 101       closeSocket' ∷ Fd → IO ()
 102       closeSocket' fd
 103           = do _ ← c'esd_close $ fdToCInt fd
 104                return ()
 105
 106 fdToCInt ∷ Fd → CInt
 107 fdToCInt (Fd fd) = fromIntegral fd
 108
 109 -- | Lock the ESD so that it won't accept connections from remote
 110 -- hosts.
 111 lock ∷ ( AncestorRegion pr cr
 112         , MonadIO cr
 113         )
 114      ⇒ Controller pr
 115      → cr ()
 116 lock co
 117     = liftIO $
 118       c'esd_lock (fdToCInt $ coSocket co)
 119           ≫= failOnError "esd_lock(fd) returned an error" (≤ 0)
 120           ≫  return ()
 121
 122 -- | Unlock the ESD so that it will accept connections from remote
 123 -- hosts.
 124 unlock ∷ ( AncestorRegion pr cr
 125           , MonadIO cr
 126           )
 127        ⇒ Controller pr
 128        → cr ()
 129 unlock co
 130     = liftIO $
 131       c'esd_unlock (fdToCInt $ coSocket co)
 132           ≫= failOnError "esd_unlock(fd) returned an error" (≤ 0)
 133           ≫  return ()
 134
 135 -- | Let ESD stop playing sounds and release its connection to the
 136 -- audio device so that other processes may use it.
 137 standby ∷ ( AncestorRegion pr cr
 138            , MonadIO cr
 139            )
 140         ⇒ Controller pr
 141         → cr ()
 142 standby co
 143     = liftIO $
 144       c'esd_standby (fdToCInt $ coSocket co)
 145           ≫= failOnError "esd_standby(fd) returned an error" (≤ 0)
 146           ≫  return ()
 147
 148 -- | Let ESD attempt to reconnect to the audio device and start
 149 -- playing sounds again.
 150 resume ∷ ( AncestorRegion pr cr
 151           , MonadIO cr
 152           )
 153        ⇒ Controller pr
 154        → cr ()
 155 resume co
 156     = liftIO $
 157       c'esd_resume (fdToCInt $ coSocket co)
 158           ≫= failOnError "esd_resume(fd) returned an error" (≤ 0)
 159           ≫  return ()
 160
 161 -- | An opaque ESD sample handle.
 162 data Sample (r ∷ ★ → ★)
 163     = Sample {
 164         saID     ∷ !CInt
 165       , saCtrl   ∷ !(Controller r)
 166       , saCloseH ∷ !(FinalizerHandle r)
 167       }
 168
 169 instance Dup Sample where
 170     dup sa = do ctrl' ← dup (saCtrl   sa)
 171                 ch'   ← dup (saCloseH sa)
 172                 return sa {
 173                          saCtrl   = ctrl'
 174                        , saCloseH = ch'
 175                        }
 176
 177 class (Frame fr, Channels ch) ⇒ SampleSource fr ch dvec where
 178     -- | Cache a sample in the server.
 179     cacheSample ∷ (MonadControlIO pr)
 180                 ⇒ Controller (RegionT s pr)
 181                 → Maybe String  -- ^ name used to identify this sample to
 182                 → Int           -- ^ sample rate
 183                 → dvec          -- ^ frames in deinterleaved vectors
 184                 → RegionT s pr (Sample (RegionT s pr))
 185
 186 instance Frame fr ⇒ SampleSource fr Mono (L.Vector fr) where
 187     cacheSample co name rate v
 188         = mask_ $
 189           do sa ← createSample
 190                    co
 191                    name
 192                    rate
 193                    ((⊥) ∷ fr  )
 194                    ((⊥) ∷ Mono)
 195                    (L.length v)
 196              _  ← liftIO $
 197                    sanitizeIOError $
 198                    do h       ← fdToHandle $ coSocket co
 199                       _       ← L.hPut h v
 200                       (Fd fd) ← handleToFd h
 201                       c'esd_confirm_sample_cache fd
 202                           ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
 203              return sa
 204
 205 instance Frame fr ⇒ SampleSource fr Stereo (L.Vector fr, L.Vector fr) where
 206     cacheSample co name rate (l, r)
 207         = mask_ $
 208           do sa ← createSample
 209                    co
 210                    name
 211                    rate
 212                    ((⊥) ∷ fr    )
 213                    ((⊥) ∷ Stereo)
 214                    (L.length l)
 215              _  ← liftIO $
 216                    sanitizeIOError $
 217                    do h       ← fdToHandle $ coSocket co
 218                       _       ← L.hPut h (interleave l r)
 219                       (Fd fd) ← handleToFd h
 220                       c'esd_confirm_sample_cache fd
 221                           ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
 222              return sa
 223
 224 createSample ∷ ∀fr ch s pr.
 225                 ( Frame fr
 226                 , Channels ch
 227                 , MonadControlIO pr
 228                 )
 229              ⇒ Controller (RegionT s pr)
 230              → Maybe String
 231              → Int
 232              → fr
 233              → ch
 234              → Int
 235              → RegionT s pr (Sample (RegionT s pr))
 236 createSample co name rate _ _ len
 237     = mask_ $
 238       do sid ← liftIO newCache
 239          ch  ← onExit $ deleteCache sid
 240          return Sample {
 241                       saID     = sid
 242                     , saCtrl   = co
 243                     , saCloseH = ch
 244                     }
 245     where
 246       fmt ∷ C'esd_format_t
 247       fmt = frameFmt   ((⊥) ∷ fr) .|.
 248             channelFmt ((⊥) ∷ ch) .|.
 249             c'ESD_SAMPLE
 250
 251       sampleSize ∷ Int
 252       sampleSize = len
 253                    ⋅ frameSize   ((⊥) ∷ fr)
 254                    ⋅ numChannels ((⊥) ∷ ch)
 255
 256       newCache ∷ IO CInt
 257       newCache = withCStrOrNull name $ \namePtr →
 258                      c'esd_sample_cache
 259                      (fdToCInt $ coSocket co)
 260                      fmt
 261                      (fromIntegral rate)
 262                      (fromIntegral sampleSize)
 263                      namePtr
 264                      ≫= failOnError ( printf "esd_sample_cache(%s, %s, %s, %s, %s) returned an error"
 265                                               (show $ coSocket co)
 266                                               (show fmt)
 267                                               (show rate)
 268                                               (show sampleSize)
 269                                               (show name)
 270                                      ) (< 0)
 271
 272       deleteCache ∷ CInt → IO ()
 273       deleteCache sid
 274           = c'esd_sample_free (fdToCInt $ coSocket co) sid
 275             ≫= failOnError ( printf "esd_sample_free(%s) returned an error"
 276                                      (show $ coSocket co)
 277                                      (show sid)
 278                             ) (< 0)
 279             ≫  return ()
 280
 281 -- | Play a cached sample once.
 282 playSample ∷ ( AncestorRegion pr cr
 283               , MonadIO cr
 284               )
 285            ⇒ Sample pr
 286            → cr ()
 287 playSample sa
 288     = liftIO $
 289       c'esd_sample_play (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 290           ≫= failOnError ( printf "esd_sample_play(%s, %s) returned an error"
 291                                    (show $ coSocket $ saCtrl sa)
 292                                    (show $ saID sa)
 293                           ) (≤ 0)
 294           ≫  return ()
 295
 296 -- | Play a cached sample repeatedly.
 297 loopSample ∷ ( AncestorRegion pr cr
 298               , MonadIO cr
 299               )
 300            ⇒ Sample pr
 301            → cr ()
 302 loopSample sa
 303     = liftIO $
 304       c'esd_sample_loop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 305           ≫= failOnError ( printf "esd_sample_loop(%s, %s) returned an error"
 306                                    (show $ coSocket $ saCtrl sa)
 307                                    (show $ saID sa)
 308                           ) (≤ 0)
 309           ≫  return ()
 310
 311 -- | Stop a looping sample at end.
 312 stopSample ∷ ( AncestorRegion pr cr
 313               , MonadIO cr
 314               )
 315            ⇒ Sample pr
 316            → cr ()
 317 stopSample sa
 318     = liftIO $
 319       c'esd_sample_stop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 320           ≫= failOnError ( printf "esd_sample_stop(%s, %s) returned an error"
 321                                    (show $ coSocket $ saCtrl sa)
 322                                    (show $ saID sa)
 323                           ) (≤ 0)
 324           ≫  return ()
 325
 326 -- | Stop a playing sample immediately.
 327 killSample ∷ ( AncestorRegion pr cr
 328               , MonadIO cr
 329               )
 330            ⇒ Sample pr
 331            → cr ()
 332 killSample sa
 333     = liftIO $
 334       c'esd_sample_kill (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 335           ≫= failOnError ( printf "esd_sample_kill(%s, %s) returned an error"
 336                                    (show $ coSocket $ saCtrl sa)
 337                                    (show $ saID sa)
 338                           ) (≤ 0)
 339           ≫  return ()
 340
 341 data FrameType
 342     = Int8 | Int16
 343     deriving (Show, Eq)
 344
 345 data NumChannels
 346     = Mono | Stereo
 347     deriving (Show, Eq)
 348
 349 -- | A data type to represent the server info.
 350 data ServerInfo
 351     = ServerInfo {
 352         serverVersion    ∷ !Int
 353       , serverFrameType  ∷ !FrameType
 354       , serverChannels   ∷ !NumChannels
 355       , serverSampleRate ∷ !Int
 356       }
 357     deriving (Show, Eq)
 358
 359 extractServerInfo ∷ Ptr C'esd_server_info → IO ServerInfo
 360 extractServerInfo siPtr
 361     = do si ← peek siPtr
 362          return ServerInfo {
 363                       serverVersion
 364                         = fromIntegral $ c'esd_server_info'version si
 365                     , serverFrameType
 366                         = extractFrameType $ c'esd_server_info'format si
 367                     , serverChannels
 368                         = extractNumChannels $ c'esd_server_info'format si
 369                     , serverSampleRate
 370                         = fromIntegral $ c'esd_server_info'rate si
 371                     }
 372
 373 extractFrameType ∷ C'esd_format_t → FrameType
 374 extractFrameType fmt
 375     | fmt .&. c'ESD_BITS8  ≢ 0 = Int8
 376     | fmt .&. c'ESD_BITS16 ≢ 0 = Int16
 377     | otherwise                = error ("Unknown format: " ⧺ show fmt)
 378
 379 extractNumChannels ∷ C'esd_format_t → NumChannels
 380 extractNumChannels fmt
 381     | fmt .&. c'ESD_MONO   ≢ 0 = Mono
 382     | fmt .&. c'ESD_STEREO ≢ 0 = Stereo
 383     | otherwise                = error ("Unknown format: " ⧺ show fmt)
 384
 385 -- | Retrieve server properties.
 386 getServerInfo ∷ ( AncestorRegion pr cr
 387                  , MonadIO cr
 388                  )
 389               ⇒ Controller pr
 390               → cr ServerInfo
 391 getServerInfo co
 392     = liftIO $
 393       bracket retrieve dispose extractServerInfo
 394     where
 395       retrieve ∷ IO (Ptr C'esd_server_info)
 396       retrieve = c'esd_get_server_info (fdToCInt $ coSocket co)
 397                  ≫= failOnError "esd_get_server_info(fd) returned an error" (≡ nullPtr)
 398
 399       dispose ∷ Ptr C'esd_server_info → IO ()
 400       dispose = c'esd_free_server_info
 401
 402 -- | A data type to represent a player stream info.
 403 data PlayerInfo
 404     = PlayerInfo {
 405         playerID               ∷ !Int
 406       , playerName             ∷ !String
 407       , playerSampleRate       ∷ !Int
 408       , playerFrameType        ∷ !FrameType
 409       , playerChannels         ∷ !NumChannels
 410       , playerLeftVolumeScale  ∷ !Double -- ^ 0 <= scale <= 1
 411       , playerRightVolumeScale ∷ !Double -- ^ 0 <= scale <= 1
 412       }
 413     deriving (Show, Eq)
 414
 415 extractPlayerInfo ∷ Ptr C'esd_player_info → IO [PlayerInfo]
 416 extractPlayerInfo piPtr
 417     | piPtr ≡ nullPtr = return []
 418     | otherwise
 419         = do pi ← peek piPtr
 420              let next = c'esd_player_info'next pi
 421                  pi'  = PlayerInfo {
 422                           playerID
 423                             = fromIntegral $ c'esd_player_info'source_id pi
 424                         , playerName
 425                             = map (chr ∘ fromIntegral) $ c'esd_player_info'name pi
 426                         , playerSampleRate
 427                             = fromIntegral $ c'esd_player_info'rate pi
 428                         , playerFrameType
 429                             = extractFrameType $ c'esd_player_info'format pi
 430                         , playerChannels
 431                             = extractNumChannels $ c'esd_player_info'format pi
 432                         , playerLeftVolumeScale
 433                             = (fromIntegral $ c'esd_player_info'left_vol_scale pi)
 434                               ÷
 435                               c'ESD_VOLUME_BASE
 436                         , playerRightVolumeScale
 437                             = (fromIntegral $ c'esd_player_info'right_vol_scale pi)
 438                               ÷
 439                               c'ESD_VOLUME_BASE
 440                         }
 441              pi'' ← extractPlayerInfo next
 442              return (pi' : pi'')
 443
 444 -- | A data type to represent a cached sample info.
 445 data SampleInfo
 446     = SampleInfo {
 447         sampleID               ∷ !Int
 448       , sampleName             ∷ !String
 449       , sampleSampleRate       ∷ !Int
 450       , sampleFrameType        ∷ !FrameType
 451       , sampleChannels         ∷ !NumChannels
 452       , sampleLength           ∷ !Int
 453       , sampleLeftVolumeScale  ∷ !Double -- ^ 0 <= scale <= 1
 454       , sampleRightVolumeScale ∷ !Double -- ^ 0 <= scale <= 1
 455       }
 456     deriving (Show, Eq)
 457
 458 extractSampleLength ∷ FrameType → NumChannels → Int → Int
 459 extractSampleLength fr ch bufLen
 460     = bufLen
 461       `div`
 462       case fr of
 463         Int8  → 1
 464         Int16 → 2
 465       `div`
 466       case ch of
 467         Mono   → 1
 468         Stereo → 2
 469
 470 extractSampleInfo ∷ Ptr C'esd_sample_info → IO [SampleInfo]
 471 extractSampleInfo piPtr
 472     | piPtr ≡ nullPtr = return []
 473     | otherwise
 474         = do pi ← peek piPtr
 475              let next = c'esd_sample_info'next pi
 476                  fr   = extractFrameType $ c'esd_sample_info'format pi
 477                  ch   = extractNumChannels $ c'esd_sample_info'format pi
 478                  pi'  = SampleInfo {
 479                           sampleID
 480                             = fromIntegral $ c'esd_sample_info'sample_id pi
 481                         , sampleName
 482                             = map (chr ∘ fromIntegral) $ c'esd_sample_info'name pi
 483                         , sampleSampleRate
 484                             = fromIntegral $ c'esd_sample_info'rate pi
 485                         , sampleFrameType
 486                             = fr
 487                         , sampleChannels
 488                             = ch
 489                         , sampleLength
 490                             = extractSampleLength fr ch $
 491                               fromIntegral $ c'esd_sample_info'length pi
 492                         , sampleLeftVolumeScale
 493                             = (fromIntegral $ c'esd_sample_info'left_vol_scale pi)
 494                               ÷
 495                               c'ESD_VOLUME_BASE
 496                         , sampleRightVolumeScale
 497                             = (fromIntegral $ c'esd_sample_info'right_vol_scale pi)
 498                               ÷
 499                               c'ESD_VOLUME_BASE
 500                         }
 501              pi'' ← extractSampleInfo next
 502              return (pi' : pi'')
 503
 504 -- | A data type to represent all info in the ESD server.
 505 data AllInfo
 506     = AllInfo {
 507         serverInfo  ∷ !ServerInfo
 508       , playersInfo ∷ ![PlayerInfo]
 509       , samplesInfo ∷ ![SampleInfo]
 510       }
 511     deriving (Show, Eq)
 512
 513 extractAllInfo ∷ Ptr C'esd_info → IO AllInfo
 514 extractAllInfo eiPtr
 515     = do ei  ← peek eiPtr
 516          srv ← extractServerInfo $ c'esd_info'server      ei
 517          pis ← extractPlayerInfo $ c'esd_info'player_list ei
 518          sis ← extractSampleInfo $ c'esd_info'sample_list ei
 519          return AllInfo {
 520                       serverInfo  = srv
 521                     , playersInfo = pis
 522                     , samplesInfo = sis
 523                     }
 524
 525 -- | Retrieve all info in the ESD server.
 526 getAllInfo ∷ ( AncestorRegion pr cr
 527               , MonadIO cr
 528               )
 529            ⇒ Controller pr
 530            → cr AllInfo
 531 getAllInfo co
 532     = liftIO $
 533       bracket retrieve dispose extractAllInfo
 534     where
 535       retrieve ∷ IO (Ptr C'esd_info)
 536       retrieve = c'esd_get_all_info (fdToCInt $ coSocket co)
 537                  ≫= failOnError "esd_get_all_info(fd) returned an error" (≡ nullPtr)
 538
 539       dispose ∷ Ptr C'esd_info → IO ()
 540       dispose = c'esd_free_all_info
 541
 542 -- | Reset the volume panning for a stream.
 543 setStreamPan ∷ ( AncestorRegion pr cr
 544                 , MonadIO cr
 545                 )
 546              ⇒ Controller pr
 547              → Int    -- ^ Stream ID
 548              → Double -- ^ left volume: 0 <= scale <= 1
 549              → Double -- ^ right volume: 0 <= scale <= 1
 550              → cr ()
 551 setStreamPan co sid l r
 552     = liftIO $
 553       c'esd_set_stream_pan (fdToCInt $ coSocket co)
 554                            (fromIntegral sid)
 555                            (floor $ l ⋅ c'ESD_VOLUME_BASE)
 556                            (floor $ r ⋅ c'ESD_VOLUME_BASE)
 557           ≫= failOnError ( printf "esd_set_stream_pan(%s, %s, %s, %s) returned an error"
 558                                    (show $ coSocket co)
 559                                    (show sid)
 560                                    (show l  )
 561                                    (show r  )
 562                           ) (≤ 0)
 563           ≫  return ()
 564
 565 -- | Reset the default volume panning for a sample.
 566 setDefaultSamplePan ∷ ( AncestorRegion pr cr
 567                        , MonadIO cr
 568                        )
 569                     ⇒ Controller pr
 570                     → Int    -- ^ Sample ID
 571                     → Double -- ^ left volume: 0 <= scale <= 1
 572                     → Double -- ^ right volume: 0 <= scale <= 1
 573                     → cr ()
 574 setDefaultSamplePan co sid l r
 575     = liftIO $
 576       c'esd_set_default_sample_pan (fdToCInt $ coSocket co)
 577                                    (fromIntegral sid)
 578                                    (floor $ l ⋅ c'ESD_VOLUME_BASE)
 579                                    (floor $ r ⋅ c'ESD_VOLUME_BASE)
 580           ≫= failOnError ( printf "esd_set_default_sample_pan(%s, %s, %s, %s) returned an error"
 581                                    (show $ coSocket co)
 582                                    (show sid)
 583                                    (show l  )
 584                                    (show r  )
 585                           ) (≤ 0)
 586           ≫  return ()
 587
 588 -- | A data type to represent server's state.
 589 data ServerState
 590     = Standby
 591     | AutoStandby
 592     | Running
 593     deriving (Eq, Show)
 594
 595 extractServerState ∷ C'esd_standby_mode_t → ServerState
 596 extractServerState st
 597     | st ≡ c'ESM_ON_STANDBY     = Standby
 598     | st ≡ c'ESM_ON_AUTOSTANDBY = AutoStandby
 599     | st ≡ c'ESM_RUNNING        = Running
 600     | otherwise                  = error ("unknown state: " ⧺ show st)
 601
 602 -- | Retrieve the server's state.
 603 getServerState ∷ ( AncestorRegion pr cr
 604                   , MonadIO cr
 605                   )
 606                ⇒ Controller pr
 607                → cr ServerState
 608 getServerState co
 609     = liftIO $
 610       fmap extractServerState $
 611       c'esd_get_standby_mode (fdToCInt $ coSocket co)
 612           ≫= failOnError "esd_get_standby_mode(fd) returned an error" (≡ c'ESM_ERROR)