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