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