Split controller OSC off from SuperDirt handshake OSC (Redux for 1.9)

src/Sound/Tidal/Stream/Config.hs

@@ -1,5 +1,7 @@
 module Sound.Tidal.Stream.Config where
 
+import           Control.Monad     (when)
+
 import qualified Sound.Tidal.Clock as Clock
 
 {-
@@ -20,15 +22,15 @@ import qualified Sound.Tidal.Clock as Clock
     along with this library.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-data Config = Config {cCtrlListen :: Bool,
-                      cCtrlAddr :: String,
-                      cCtrlPort :: Int,
+data Config = Config {cCtrlListen    :: Bool,
+                      cCtrlAddr      :: String,
+                      cCtrlPort      :: Int,
                       cCtrlBroadcast :: Bool,
                       -- cTempoAddr :: String,
                       -- cTempoPort :: Int,
                       -- cTempoClientPort :: Int,
-                      cVerbose :: Bool,
-                      cClockConfig :: Clock.ClockConfig
+                      cVerbose       :: Bool,
+                      cClockConfig   :: Clock.ClockConfig
                      }
 
 defaultConfig :: Config
@@ -42,3 +44,6 @@ defaultConfig = Config {cCtrlListen = True,
                         cVerbose = True,
                         cClockConfig = Clock.defaultConfig
                        }
+
+verbose :: Config -> String -> IO ()
+verbose c s = when (cVerbose c) $ putStrLn s

src/Sound/Tidal/Stream/Listen.hs

@@ -1,14 +1,13 @@
 module Sound.Tidal.Stream.Listen where
 
-import           Data.Maybe (fromJust, catMaybes, isJust)
 import           Control.Concurrent.MVar
-import           Control.Monad (when)
-import           System.IO (hPutStrLn, stderr)
-import qualified Data.Map as Map
-import qualified Sound.Osc.Fd as O
-import qualified Sound.Osc.Time.Timeout as O
-import qualified Network.Socket         as N
-import qualified Control.Exception as E
+import qualified Control.Exception         as E
+import           Control.Monad             (when)
+import qualified Data.Map                  as Map
+import           Data.Maybe                (fromJust)
+import qualified Network.Socket            as N
+import qualified Sound.Osc.Fd              as O
+import           System.IO                 (hPutStrLn, stderr)
 
 import           Sound.Tidal.ID
 import           Sound.Tidal.Pattern
@@ -50,29 +49,14 @@ openListener c
         catchAny = E.catch
 
 -- Listen to and act on OSC control messages
-ctrlResponder :: Int -> Config -> Stream -> IO ()
-ctrlResponder waits c (stream@(Stream {sListen = Just sock}))
-  = do ms <- recvMessagesTimeout 2 sock
-       if (null ms)
-         then do checkHandshake -- there was a timeout, check handshake
-                 ctrlResponder (waits+1) c stream
-         else do mapM_ act ms
-                 ctrlResponder 0 c stream
-     where
-        checkHandshake = do busses <- readMVar (sBusses stream)
-                            when (null busses) $ do when  (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."
-                                                    sendHandshakes stream
-
-        act (O.Message "/dirt/hello" _) = sendHandshakes stream
-        act (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar (sBusses stream) $ bufferIndices xs
-                                                        -- Only report the first time..
-                                                        when (null prev) $ verbose c $ "Connected to SuperDirt."
-                                                        return ()
-          where
-            bufferIndices [] = []
-            bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
-                                  | otherwise = bufferIndices xs'
+ctrlResponder :: Config -> Stream -> IO ()
+ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop
+      where
+        loop :: IO ()
+        loop = do O.recvMessages sock >>= mapM_ act
+                  loop
         -- External controller commands
+        act :: O.Message -> IO ()
         act (O.Message "/ctrl" (O.Int32 k:v:[]))
           = act (O.Message "/ctrl" [O.string $ show k,v])
         act (O.Message "/ctrl" (O.AsciiString k:v@(O.Float _):[]))
@@ -107,12 +91,6 @@ ctrlResponder waits c (stream@(Stream {sListen = Just sock}))
                      return ()
         withID :: O.Datum -> (ID -> IO ()) -> IO ()
         withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k
-        withID (O.Int32 k) func = func $ (ID . show) k
-        withID _ _ = return ()
-ctrlResponder _ _ _ = return ()
-
-verbose :: Config -> String -> IO ()
-verbose c s = when (cVerbose c) $ putStrLn s
-
-recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
-recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
+        withID (O.Int32 k) func       = func $ (ID . show) k
+        withID _ _                    = return ()
+ctrlResponder _ _ = return ()

src/Sound/Tidal/Stream/Main.hs

@@ -1,19 +1,18 @@
 module Sound.Tidal.Stream.Main where
 
-import qualified Data.Map as Map
-import qualified Sound.Tidal.Clock as Clock
-import           Control.Concurrent.MVar
 import           Control.Concurrent
-import           System.IO (hPutStrLn, stderr)
+import           Control.Concurrent.MVar
+import qualified Data.Map                   as Map
+import qualified Sound.Tidal.Clock          as Clock
+import           System.IO                  (hPutStrLn, stderr)
 
 
-import           Sound.Tidal.Version (tidal_status_string)
 import           Sound.Tidal.Stream.Config
-import           Sound.Tidal.Stream.Types
 import           Sound.Tidal.Stream.Listen
-import           Sound.Tidal.Stream.Target
 import           Sound.Tidal.Stream.Process
-import           Sound.Tidal.Stream.UI
+import           Sound.Tidal.Stream.Target
+import           Sound.Tidal.Stream.Types
+import           Sound.Tidal.Version        (tidal_status_string)
 
 {-
     Main.hs - Start tidals stream, listen and act on incoming messages
@@ -45,7 +44,6 @@
 startStream config oscmap = do
        sMapMV <- newMVar Map.empty
        pMapMV <- newMVar Map.empty
-       bussesMV <- newMVar []
        globalFMV <- newMVar id
 
        tidal_status_string >>= verbose config
@@ -54,10 +52,9 @@
 
        cxs <- getCXs config oscmap
 
-       clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen)
+       clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV pMapMV globalFMV cxs)
 
        let stream = Stream {sConfig = config,
-                            sBusses = bussesMV,
                             sStateMV  = sMapMV,
                             sClockRef = clockRef,
                             -- sLink = abletonLink,
@@ -68,10 +65,8 @@
                             sCxs = cxs
                            }
 
-       sendHandshakes stream
-
        -- Spawn a thread to handle OSC control messages
-       _ <- forkIO $ ctrlResponder 0 config stream
+       _ <- forkIO $ ctrlResponder config stream
        return stream
 
 startMulti :: [Target] -> Config -> IO ()

src/Sound/Tidal/Stream/Process.hs

@@ -81,23 +81,20 @@ data ProcessedEvent =
 -- because the likely reason is that something is wrong with the current pattern.
 
 doTick :: MVar ValueMap                           -- pattern state
-       -> MVar [Int]                              -- busses
        -> MVar PlayMap                            -- currently playing
        -> MVar (ControlPattern -> ControlPattern) -- current global fx
        -> [Cx]                                    -- target addresses
-       -> Maybe O.Udp                             -- network socket
        -> (Time,Time)                             -- current arc
        -> Double                                  -- nudge
        -> Clock.LinkOperations                    -- ableton link operations
        -> IO ()
-doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge ops =
+doTick stateMV playMV globalFMV cxs (st,end) nudge ops =
   E.handle (\ (e :: E.SomeException) -> do
     hPutStrLn stderr $ "Failed to Stream.doTick: " ++ show e
     hPutStrLn stderr $ "Return to previous pattern."
     setPreviousPatternOrSilence playMV) (do
       sMap <- takeMVar stateMV
       pMap <- readMVar playMV
-      busses <- readMVar busMV
       sGlobalF <- readMVar globalFMV
       bpm <- (Clock.getTempo ops)
       let
@@ -114,13 +111,14 @@ doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge ops =
         (sMap'', es') = resolveState sMap' es
       tes <- processCps ops es'
       -- For each OSC target
-      forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do
+      forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do
+              busses <- mapM readMVar bussesMV
               -- Latency is configurable per target.
               -- Latency is only used when sending events live.
               let latency = oLatency target
                   ms = concatMap (\e ->  concatMap (toOSC busses e) oscs) tes
               -- send the events to the OSC target
-              forM_ ms $ \m -> (send listen cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
+              forM_ ms $ \m -> (send cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
                 hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
       putMVar stateMV sMap'')
 
@@ -159,8 +157,8 @@ processCps ops = mapM processEvent
         }
 
 
-toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
-toOSC busses pe osc@(OSC _ _)
+toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
+toOSC maybeBusses pe osc@(OSC _ _)
   = catMaybes (playmsg:busmsgs)
       -- playmap is a ValueMap where the keys don't start with ^ and are not ""
       -- busmap is a ValueMap containing the rest of the keys from the event value
@@ -195,15 +193,15 @@ toOSC busses pe osc@(OSC _ _)
                           O.Message mungedPath vs
                           )
                 | otherwise = Nothing
-        toBus n | null busses = n
-                | otherwise = busses !!! n
+        toBus n | Just busses <- maybeBusses, (not . null) busses = busses !!! n
+                | otherwise = n
         busmsgs = map
                     (\(k, b) -> do k' <- if (not $ null k) && head k == '^' then Just (tail k) else Nothing
                                    v <- Map.lookup k' playmap
                                    bi <- getI b
                                    return $ (tsPart,
                                              True, -- bus message ?
-                                             O.Message "/c_set" [O.int32 bi, toDatum v]
+                                             O.Message "/c_set" [O.int32 (toBus bi), toDatum v]
                                             )
                     )
                     (Map.toList busmap)
@@ -289,8 +287,8 @@ hasSolo = (>= 1) . length . filter psSolo . Map.elems
 -- However, since the full arc is processed at once and since Link does not support
 -- scheduling, tempo change may affect scheduling of events that happen earlier
 -- in the normal stream (the one handled by onTick).
-onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> ControlPattern -> IO ()
-onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do
+onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO ()
+onSingleTick config clockRef stateMV _ globalFMV cxs pat = do
   ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef
   pMapMV <- newMVar $ Map.singleton "fake"
           (PlayState {psPattern = pat,
@@ -300,7 +298,7 @@ onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do
                       }
           )
   -- The nowArc is a full cycle
-  doTick stateMV busMV pMapMV globalFMV cxs listen (0,1) 0 ops
+  doTick stateMV pMapMV globalFMV cxs (0,1) 0 ops
 
 
 

src/Sound/Tidal/Stream/Target.hs

@@ -1,14 +1,17 @@
 module Sound.Tidal.Stream.Target where
 
-import qualified Sound.Osc.Fd           as O
-import qualified Network.Socket         as N
-import           Data.Maybe             (fromJust, isJust)
-import           Control.Concurrent     (forkOS, threadDelay)
-import           Foreign                (Word8)
+import           Control.Concurrent        (forkIO, forkOS, newMVar, readMVar,
+                                            swapMVar, threadDelay)
+import           Control.Monad             (when)
+import           Data.Maybe                (catMaybes, fromJust, isJust)
+import           Foreign                   (Word8)
+import qualified Network.Socket            as N
+import qualified Sound.Osc.Fd              as O
+import qualified Sound.Osc.Time.Timeout    as O
 
 import           Sound.Tidal.Pattern
-import           Sound.Tidal.Stream.Types
 import           Sound.Tidal.Stream.Config
+import           Sound.Tidal.Stream.Types
 
 {-
     Target.hs - Create and send to OSC targets
@@ -31,33 +34,65 @@ import           Sound.Tidal.Stream.Config
 
 getCXs :: Config -> [(Target, [OSC])] -> IO [Cx]
 getCXs config oscmap = mapM (\(target, os) -> do
-                                          remote_addr <- resolve (oAddress target) (show $ oPort target)
-                                          remote_bus_addr <- if isJust $ oBusPort target
-                                                              then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target)
-                                                              else return Nothing
+                                          remote_addr <- resolve (oAddress target) (oPort target)
+                                          remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target)
+                                          remote_busses <- sequence (oBusPort target >> Just (newMVar []))
+
                                           let broadcast = if cCtrlBroadcast config then 1 else 0
-                                          u <- O.udp_socket (\sock sockaddr -> do N.setSocketOption sock N.Broadcast broadcast
-                                                                                  N.connect sock sockaddr
+                                          u <- O.udp_socket (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast
                                                              ) (oAddress target) (oPort target)
-                                          return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os}
+                                          let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os}
+                                          _ <- forkIO $ handshake cx config
+                                          return cx
             ) oscmap
 
-resolve :: String -> String -> IO N.AddrInfo
+resolve :: String -> Int -> IO N.AddrInfo
 resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream }
-                       addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port)
+                       addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port)
                        return addr
 
+handshake :: Cx -> Config -> IO ()
+handshake Cx { cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr } c = sendHandshake >> listen 0
+  where
+    sendHandshake :: IO ()
+    sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr)
+    listen :: Int -> IO ()
+    listen waits = do ms <- recvMessagesTimeout 2 udp
+                      if null ms
+                      then do checkHandshake waits -- there was a timeout, check handshake
+                              listen (waits+1)
+                      else do mapM_ respond ms
+                              listen 0
+    checkHandshake :: Int -> IO ()
+    checkHandshake waits = do busses <- readMVar bussesMV
+                              when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."
+                                                      sendHandshake
+    respond :: O.Message -> IO ()
+    respond (O.Message "/dirt/hello" _) = sendHandshake
+    respond (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar bussesMV $ bufferIndices xs
+                                                        -- Only report the first time..
+                                                        when (null prev) $ verbose c $ "Connected to SuperDirt."
+    respond _ = return ()
+    bufferIndices :: [O.Datum] -> [Int]
+    bufferIndices [] = []
+    bufferIndices (x:xs') | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
+                          | otherwise = bufferIndices xs'
+handshake _ _ = return ()
+
+recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
+recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
+
 -- send has three modes:
 -- Send events early using timestamp in the OSC bundle - used by Superdirt
 -- Send events early by adding timestamp to the OSC message - used by Dirt
 -- Send events live by delaying the thread
-send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
-send listen cx latency extraLatency (time, isBusMsg, m)
-  | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m]
-  | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m
+send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
+send cx latency extraLatency (time, isBusMsg, m)
+  | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m]
+  | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m
   | otherwise = do _ <- forkOS $ do now <- O.time
                                     threadDelay $ floor $ (timeWithLatency - now) * 1000000
-                                    sendO isBusMsg listen cx m
+                                    sendO isBusMsg cx m
                    return ()
     where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params))
           ut = O.ntpr_to_posix timeWithLatency
@@ -68,18 +103,15 @@ send listen cx latency extraLatency (time, isBusMsg, m)
           target = cxTarget cx
           timeWithLatency = time - latency + extraLatency
 
-sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO ()
-sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr)
+sendBndl :: Bool -> Cx -> O.Bundle -> IO ()
+sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr)
   where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
              | otherwise = cxAddr cx
-sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl
-
-sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO ()
-sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr)
- where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
-            | otherwise = cxAddr cx
-sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg
 
+sendO :: Bool -> Cx -> O.Message -> IO ()
+sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr)
+  where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
+             | otherwise = cxAddr cx
 
 superdirtTarget :: Target
 superdirtTarget = Target {oName = "SuperDirt",