Controller (partway)

diff --git a/EsounD.cabal b/EsounD.cabal
index aec3495ba024619e08cb29c0cc25efa12bc55504..422b805b9bebd1ccf09a91e74a7dce16c0ef2b48 100644 (file)
--- a/EsounD.cabal
+++ b/EsounD.cabal
@@ -39,6 +39,7 @@ Library
 
     Exposed-Modules:
         Sound.EsounD
+        Sound.EsounD.Controller
         Sound.EsounD.Filter
         Sound.EsounD.Monitor
         Sound.EsounD.Player

diff --git a/Sound/EsounD/Controller.hs b/Sound/EsounD/Controller.hs
new file mode 100644 (file)
index 0000000..1353d06
--- /dev/null
+++ b/Sound/EsounD/Controller.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE
+    FlexibleContexts
+  , FlexibleInstances
+  , KindSignatures
+  , MultiParamTypeClasses
+  , UnicodeSyntax
+  , ScopedTypeVariables
+  #-}
+-- | EsounD controlling handles.
+module Sound.EsounD.Controller
+    ( Controller
+    , openController
+
+    , lock
+    , unlock
+    )
+    where
+import Bindings.EsounD
+import Control.Exception.Peel
+import Control.Monad.IO.Class
+import Control.Monad.IO.Peel
+import Control.Monad.Trans.Region
+import Control.Monad.Trans.Region.OnExit
+import Control.Monad.Unicode
+import Foreign.C.Types
+import Network
+import Sound.EsounD.Internals
+import System.IO.SaferFileHandles.Unsafe
+import System.Posix.Types
+import Text.Printf
+
+-- ^ An opaque ESD handle for controlling ESD.
+data Controller (r ∷ ★ → ★)
+    = Controller {
+        coSocket ∷ !Fd
+      , coCloseH ∷ !(FinalizerHandle r)
+      }
+
+instance Dup Controller where
+    dup co = do ch' ← dup (coCloseH co)
+                return co { coCloseH = ch' }
+
+-- | Open an ESD handle for controlling ESD.
+openController ∷ MonadPeelIO pr
+               ⇒ Maybe HostName -- ^ host to connect to.
+               → RegionT s pr (Controller (RegionT s pr))
+openController host
+    = block $
+      do s  ← liftIO openSocket
+         ch ← onExit $ sanitizeIOError $ closeSocket' s
+         return Controller {
+                      coSocket = s
+                    , coCloseH = ch
+                    }
+    where
+      openSocket ∷ IO Fd
+      openSocket = withCStrOrNull host $ \hostPtr →
+                       c'esd_open_sound hostPtr
+                       ≫= wrapSocket'
+
+      wrapSocket' ∷ Monad m ⇒ CInt → m Fd
+      wrapSocket' (-1) = fail ( printf "esd_open_sound(%s) returned an error"
+                                       (show host)
+                              )
+      wrapSocket' fd   = return $ Fd fd
+
+      closeSocket' ∷ Fd → IO ()
+      closeSocket' fd
+          = do _ ← c'esd_close $ fdToCInt fd
+               return ()
+
+fdToCInt ∷ Fd → CInt
+fdToCInt (Fd fd) = fromIntegral fd
+
+-- | Lock the ESD so that it won't accept connections from remote
+-- hosts.
+lock ∷ ( AncestorRegion pr cr
+        , MonadIO cr
+        )
+     ⇒ Controller pr
+     → cr ()
+lock co
+    = liftIO $
+      sanitizeIOError $
+      c'esd_lock (fdToCInt $ coSocket co)
+          ≫= failOnError "esd_lock(fd) returned an error"
+
+-- | Unlock the ESD so that it will accept connections from remote
+-- hosts.
+unlock ∷ ( AncestorRegion pr cr
+          , MonadIO cr
+          )
+       ⇒ Controller pr
+       → cr ()
+unlock co
+    = liftIO $
+      sanitizeIOError $
+      c'esd_unlock (fdToCInt $ coSocket co)
+          ≫= failOnError "esd_unlock(fd) returned an error"

diff --git a/Sound/EsounD/Internals.hs b/Sound/EsounD/Internals.hs
index 60cf4b922b39d02aea0e26ab24e6b7047691ee75..f4b067f0903cf30fc9a23b62ccb13dee41c5e4fe 100644 (file)
--- a/Sound/EsounD/Internals.hs
+++ b/Sound/EsounD/Internals.hs
@@ -14,10 +14,10 @@ module Sound.EsounD.Internals
     , deinterleave
 
     , toLSV
-
     , wrapSocket
     , closeSocket
     , withCStrOrNull
+    , failOnError
     )
     where
 import Bindings.EsounD
@@ -28,6 +28,7 @@ import Foreign.C.String
 import Foreign.C.Types
 import Foreign.Ptr
 import Foreign.Storable
+import Prelude.Unicode
 import System.IO
 import System.Posix.IO
 import System.Posix.Types
@@ -97,3 +98,8 @@ closeSocket h = do (Fd fd) ← handleToFd h
 withCStrOrNull ∷ Maybe String → (CString → IO a) → IO a
 withCStrOrNull Nothing  f = f nullPtr
 withCStrOrNull (Just s) f = withCString s f
+
+failOnError ∷ Monad m ⇒ String → CInt → m ()
+failOnError msg rv
+    | rv ≤ 0   = fail msg
+    | otherwise = return ()