Controller (partway)

[EsounD.git] / Sound / EsounD / Controller.hs

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"