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     where
  33 import Bindings.EsounD
  34 import Control.Exception.Peel
  35 import Control.Monad.IO.Class
  36 import Control.Monad.IO.Peel
  37 import Control.Monad.Trans.Region
  38 import Control.Monad.Trans.Region.OnExit
  39 import Control.Monad.Unicode
  40 import Data.Bits
  41 import Data.StorableVector.Lazy as L
  42 import Foreign.C.Types
  43 import Foreign.Ptr
  44 import Foreign.Storable
  45 import Network
  46 import Prelude.Unicode
  47 import Sound.EsounD.Internals
  48 import System.IO.SaferFileHandles.Unsafe
  49 import System.Posix.IO hiding (dup)
  50 import System.Posix.Types
  51 import Text.Printf
  52
  53 -- ^ An opaque ESD handle for controlling ESD.
  54 data Controller (r ∷ ★ → ★)
  55     = Controller {
  56         coSocket ∷ !Fd
  57       , coCloseH ∷ !(FinalizerHandle r)
  58       }
  59
  60 instance Dup Controller where
  61     dup co = do ch' ← dup (coCloseH co)
  62                 return co { coCloseH = ch' }
  63
  64 -- | Open an ESD handle for controlling ESD.
  65 openController ∷ MonadPeelIO pr
  66                ⇒ Maybe HostName -- ^ host to connect to.
  67                → RegionT s pr (Controller (RegionT s pr))
  68 openController host
  69     = block $
  70       do s  ← liftIO openSocket
  71          ch ← onExit $ sanitizeIOError $ closeSocket' s
  72          return Controller {
  73                       coSocket = s
  74                     , coCloseH = ch
  75                     }
  76     where
  77       openSocket ∷ IO Fd
  78       openSocket = withCStrOrNull host $ \hostPtr →
  79                        c'esd_open_sound hostPtr
  80                        ≫= wrapSocket'
  81
  82       wrapSocket' ∷ Monad m ⇒ CInt → m Fd
  83       wrapSocket' (-1) = fail ( printf "esd_open_sound(%s) returned an error"
  84                                        (show host)
  85                               )
  86       wrapSocket' fd   = return $ Fd fd
  87
  88       closeSocket' ∷ Fd → IO ()
  89       closeSocket' fd
  90           = do _ ← c'esd_close $ fdToCInt fd
  91                return ()
  92
  93 fdToCInt ∷ Fd → CInt
  94 fdToCInt (Fd fd) = fromIntegral fd
  95
  96 -- | Lock the ESD so that it won't accept connections from remote
  97 -- hosts.
  98 lock ∷ ( AncestorRegion pr cr
  99         , MonadIO cr
 100         )
 101      ⇒ Controller pr
 102      → cr ()
 103 lock co
 104     = liftIO $
 105       sanitizeIOError $
 106       c'esd_lock (fdToCInt $ coSocket co)
 107           ≫= failOnError "esd_lock(fd) returned an error" (≤ 0)
 108           ≫  return ()
 109
 110 -- | Unlock the ESD so that it will accept connections from remote
 111 -- hosts.
 112 unlock ∷ ( AncestorRegion pr cr
 113           , MonadIO cr
 114           )
 115        ⇒ Controller pr
 116        → cr ()
 117 unlock co
 118     = liftIO $
 119       sanitizeIOError $
 120       c'esd_unlock (fdToCInt $ coSocket co)
 121           ≫= failOnError "esd_unlock(fd) returned an error" (≤ 0)
 122           ≫  return ()
 123
 124 -- | Let ESD stop playing sounds and release its connection to the
 125 -- audio device so that other processes may use it.
 126 standby ∷ ( AncestorRegion pr cr
 127            , MonadIO cr
 128            )
 129         ⇒ Controller pr
 130         → cr ()
 131 standby co
 132     = liftIO $
 133       sanitizeIOError $
 134       c'esd_standby (fdToCInt $ coSocket co)
 135           ≫= failOnError "esd_standby(fd) returned an error" (≤ 0)
 136           ≫  return ()
 137
 138 -- | Let ESD attempt to reconnect to the audio device and start
 139 -- playing sounds again.
 140 resume ∷ ( AncestorRegion pr cr
 141           , MonadIO cr
 142           )
 143        ⇒ Controller pr
 144        → cr ()
 145 resume co
 146     = liftIO $
 147       sanitizeIOError $
 148       c'esd_resume (fdToCInt $ coSocket co)
 149           ≫= failOnError "esd_resume(fd) returned an error" (≤ 0)
 150           ≫  return ()
 151
 152 -- | An opaque ESD sample handle.
 153 data Sample (r ∷ ★ → ★)
 154     = Sample {
 155         saID     ∷ !CInt
 156       , saCtrl   ∷ !(Controller r)
 157       , saCloseH ∷ !(FinalizerHandle r)
 158       }
 159
 160 instance Dup Sample where
 161     dup sa = do ctrl' ← dup (saCtrl   sa)
 162                 ch'   ← dup (saCloseH sa)
 163                 return sa {
 164                          saCtrl   = ctrl'
 165                        , saCloseH = ch'
 166                        }
 167
 168 class (Frame fr, Channels ch) ⇒ SampleSource fr ch dvec where
 169     -- | Cache a sample in the server.
 170     cacheSample ∷ (MonadPeelIO pr)
 171                 ⇒ Controller (RegionT s pr)
 172                 → Maybe String  -- ^ name used to identify this sample to
 173                 → Int           -- ^ sample rate
 174                 → dvec          -- ^ frames in deinterleaved vectors
 175                 → RegionT s pr (Sample (RegionT s pr))
 176
 177 instance Frame fr ⇒ SampleSource fr Mono (L.Vector fr) where
 178     cacheSample co name rate v
 179         = block $
 180           do sa ← createSample
 181                    co
 182                    name
 183                    rate
 184                    ((⊥) ∷ fr  )
 185                    ((⊥) ∷ Mono)
 186                    (L.length v)
 187              _  ← liftIO $
 188                    sanitizeIOError $
 189                    do h       ← fdToHandle $ coSocket co
 190                       _       ← L.hPut h v
 191                       (Fd fd) ← handleToFd h
 192                       c'esd_confirm_sample_cache fd
 193                           ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
 194              return sa
 195
 196 instance Frame fr ⇒ SampleSource fr Stereo (L.Vector fr, L.Vector fr) where
 197     cacheSample co name rate (l, r)
 198         = block $
 199           do sa ← createSample
 200                    co
 201                    name
 202                    rate
 203                    ((⊥) ∷ fr    )
 204                    ((⊥) ∷ Stereo)
 205                    (L.length l)
 206              _  ← liftIO $
 207                    sanitizeIOError $
 208                    do h       ← fdToHandle $ coSocket co
 209                       _       ← L.hPut h (interleave l r)
 210                       (Fd fd) ← handleToFd h
 211                       c'esd_confirm_sample_cache fd
 212                           ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
 213              return sa
 214
 215 createSample ∷ ∀fr ch s pr.
 216                 ( Frame fr
 217                 , Channels ch
 218                 , MonadPeelIO pr
 219                 )
 220              ⇒ Controller (RegionT s pr)
 221              → Maybe String
 222              → Int
 223              → fr
 224              → ch
 225              → Int
 226              → RegionT s pr (Sample (RegionT s pr))
 227 createSample co name rate _ _ size
 228     = block $
 229       do sid ← liftIO newCache
 230          ch  ← onExit $ sanitizeIOError $ deleteCache sid
 231          return Sample {
 232                       saID     = sid
 233                     , saCtrl   = co
 234                     , saCloseH = ch
 235                     }
 236     where
 237       fmt ∷ C'esd_format_t
 238       fmt = frameFmt   ((⊥) ∷ fr) .|.
 239             channelFmt ((⊥) ∷ ch) .|.
 240             c'ESD_SAMPLE
 241
 242       newCache ∷ IO CInt
 243       newCache = withCStrOrNull name $ \namePtr →
 244                      c'esd_sample_cache
 245                      (fdToCInt $ coSocket co)
 246                      fmt
 247                      (fromIntegral rate)
 248                      (fromIntegral size)
 249                      namePtr
 250                      ≫= failOnError ( printf "esd_sample_cache(%s, %s, %s, %s, %s) returned an error"
 251                                               (show $ coSocket co)
 252                                               (show fmt)
 253                                               (show rate)
 254                                               (show size)
 255                                               (show name)
 256                                      ) (< 0)
 257
 258       deleteCache ∷ CInt → IO ()
 259       deleteCache sid
 260           = c'esd_sample_free (fdToCInt $ coSocket co) sid
 261             ≫= failOnError ( printf "esd_sample_free(%s) returned an error"
 262                                      (show $ coSocket co)
 263                                      (show sid)
 264                             ) (< 0)
 265             ≫  return ()
 266
 267 -- | Play a cached sample once.
 268 playSample ∷ ( AncestorRegion pr cr
 269               , MonadIO cr
 270               )
 271            ⇒ Sample pr
 272            → cr ()
 273 playSample sa
 274     = liftIO $
 275       sanitizeIOError $
 276       c'esd_sample_play (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 277           ≫= failOnError ( printf "esd_sample_play(%s, %s) returned an error"
 278                                    (show $ coSocket $ saCtrl sa)
 279                                    (show $ saID sa)
 280                           ) (≤ 0)
 281           ≫  return ()
 282
 283 -- | Play a cached sample repeatedly.
 284 loopSample ∷ ( AncestorRegion pr cr
 285               , MonadIO cr
 286               )
 287            ⇒ Sample pr
 288            → cr ()
 289 loopSample sa
 290     = liftIO $
 291       sanitizeIOError $
 292       c'esd_sample_loop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 293           ≫= failOnError ( printf "esd_sample_loop(%s, %s) returned an error"
 294                                    (show $ coSocket $ saCtrl sa)
 295                                    (show $ saID sa)
 296                           ) (≤ 0)
 297           ≫  return ()
 298
 299 -- | Stop a looping sample at end.
 300 stopSample ∷ ( AncestorRegion pr cr
 301               , MonadIO cr
 302               )
 303            ⇒ Sample pr
 304            → cr ()
 305 stopSample sa
 306     = liftIO $
 307       sanitizeIOError $
 308       c'esd_sample_stop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 309           ≫= failOnError ( printf "esd_sample_stop(%s, %s) returned an error"
 310                                    (show $ coSocket $ saCtrl sa)
 311                                    (show $ saID sa)
 312                           ) (≤ 0)
 313           ≫  return ()
 314
 315 -- | Stop a playing sample immediately.
 316 killSample ∷ ( AncestorRegion pr cr
 317               , MonadIO cr
 318               )
 319            ⇒ Sample pr
 320            → cr ()
 321 killSample sa
 322     = liftIO $
 323       sanitizeIOError $
 324       c'esd_sample_kill (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
 325           ≫= failOnError ( printf "esd_sample_kill(%s, %s) returned an error"
 326                                    (show $ coSocket $ saCtrl sa)
 327                                    (show $ saID sa)
 328                           ) (≤ 0)
 329           ≫  return ()
 330
 331
 332
 333 -- | A data type to represent the server info.
 334 data ServerInfo
 335     = ServerInfo {
 336         serverVersion    ∷ !Int
 337       , serverFrameType  ∷ !FrameType
 338       , serverChannels   ∷ !NumChannels
 339       , serverSampleRate ∷ !Int
 340       }
 341     deriving (Show, Eq)
 342
 343 data FrameType
 344     = Int8 | Int16
 345     deriving (Show, Eq)
 346
 347 data NumChannels
 348     = Mono | Stereo
 349     deriving (Show, Eq)
 350
 351 -- | Retrieve server properties.
 352 getServerInfo ∷ ( AncestorRegion pr cr
 353                  , MonadIO cr
 354                  )
 355               ⇒ Controller pr
 356               → cr ServerInfo
 357 getServerInfo co
 358     = liftIO $
 359       sanitizeIOError $
 360       bracket retrieve dispose extract
 361     where
 362       retrieve ∷ IO (Ptr C'esd_server_info)
 363       retrieve = do siPtr ← c'esd_get_server_info (fdToCInt $ coSocket co)
 364                     if siPtr ≡ nullPtr then
 365                         fail "esd_resume(fd) returned an error"
 366                       else
 367                         return siPtr
 368
 369       dispose ∷ Ptr C'esd_server_info → IO ()
 370       dispose = c'esd_free_server_info
 371
 372       extract ∷ Ptr C'esd_server_info → IO ServerInfo
 373       extract siPtr
 374           = do si ← peek siPtr
 375                return ServerInfo {
 376                             serverVersion
 377                                 = fromIntegral $
 378                                   c'esd_server_info'version si
 379                           , serverFrameType
 380                               = case c'esd_server_info'format si of
 381                                   fmt | fmt .&. c'ESD_BITS8  ≡ 1 → Int8
 382                                       | fmt .&. c'ESD_BITS16 ≡ 1 → Int16
 383                                       | otherwise                 →  error ("Unknown format: " ⧺ show fmt)
 384                           , serverChannels
 385                               = case c'esd_server_info'format si of
 386                                   fmt | fmt .&. c'ESD_MONO   ≡ 1 → Mono
 387                                       | fmt .&. c'ESD_STEREO ≡ 1 → Stereo
 388                                       | otherwise                 → error ("Unknown format: " ⧺ show fmt)
 389                           , serverSampleRate
 390                               = fromIntegral $
 391                                 c'esd_server_info'rate si
 392                           }