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

src/Sound/Tidal/Stream/Config.hs

@@ -1,5 +1,6 @@
 module Sound.Tidal.Stream.Config where
 
+import Control.Monad (when)
 import qualified Sound.Tidal.Clock as Clock
 
 {-
@@ -45,3 +46,6 @@ defaultConfig =
       cVerbose = True,
       cClockConfig = Clock.defaultConfig
     }
+
+verbose :: Config -> String -> IO ()
+verbose c s = when (cVerbose c) $ putStrLn s

src/Sound/Tidal/Stream/Listen.hs

@@ -4,10 +4,9 @@ import Control.Concurrent.MVar
 import qualified Control.Exception as E
 import Control.Monad (when)
 import qualified Data.Map as Map
-import Data.Maybe (catMaybes, fromJust, isJust)
+import Data.Maybe (fromJust)
 import qualified Network.Socket as N
 import qualified Sound.Osc.Fd as O
-import qualified Sound.Osc.Time.Timeout as O
 import qualified Sound.Osc.Transport.Fd.Udp as O
 import Sound.Tidal.ID
 import Sound.Tidal.Pattern
@@ -53,36 +52,15 @@ 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
+ctrlResponder :: Config -> Stream -> IO ()
+ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop
   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'
+    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 _) : [])) =
@@ -132,10 +110,4 @@ ctrlResponder waits c (stream@(Stream {sListen = Just sock})) =
     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
+ctrlResponder _ _ = return ()

src/Sound/Tidal/Stream/Main.hs

@@ -5,16 +5,15 @@ import qualified Data.Map as Map
 import qualified Sound.Tidal.Clock as Clock
 import Sound.Tidal.Stream.Config
   ( Config (cClockConfig, cCtrlAddr, cCtrlPort),
+    verbose,
   )
 import Sound.Tidal.Stream.Listen
   ( ctrlResponder,
     openListener,
-    verbose,
   )
 import Sound.Tidal.Stream.Process (doTick)
 import Sound.Tidal.Stream.Target (getCXs, superdirtShape)
 import Sound.Tidal.Stream.Types (OSC, Stream (..), Target)
-import Sound.Tidal.Stream.UI (sendHandshakes)
 import Sound.Tidal.Version (tidal_status_string)
 import System.IO (hPutStrLn, stderr)
 
@@ -47,7 +46,6 @@ startStream :: Config -> [(Target, [OSC])] -> IO Stream
 startStream config oscmap = do
   sMapMV <- newMVar Map.empty
   pMapMV <- newMVar Map.empty
-  bussesMV <- newMVar []
   globalFMV <- newMVar id
 
   tidal_status_string >>= verbose config
@@ -56,12 +54,11 @@ startStream config oscmap = do
 
   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,
@@ -72,10 +69,8 @@ startStream config oscmap = do
             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

@@ -76,22 +76,19 @@ data ProcessedEvent = 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.ClockConfig -> -- config of the clock
   Clock.ClockRef -> -- reference to the clock
   (Link.SessionState, Link.SessionState) -> -- second session state is for keeping track of tempo changes
   IO ()
-doTick stateMV busMV playMV globalFMV cxs listen (st, end) nudge cconf cref (ss, temposs) =
+doTick stateMV playMV globalFMV cxs (st, end) nudge cconf cref (ss, temposs) =
   E.handle handleException $ do
     modifyMVar_ stateMV $ \sMap -> do
       pMap <- readMVar playMV
-      busses <- readMVar busMV
       sGlobalF <- readMVar globalFMV
       bpm <- Clock.getTempo ss
       let patstack = sGlobalF $ playStack pMap
@@ -112,14 +109,15 @@ doTick stateMV busMV playMV globalFMV cxs listen (st, end) nudge cconf cref (ss,
           (sMap'', es') = resolveState sMap' es
       tes <- processCps cconf cref (ss, temposs) 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) ->
+          (send cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
             hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
       return sMap''
   where
@@ -168,8 +166,8 @@ processCps cconf cref (ss, temposs) = mapM processEvent
             peOnPartOsc = onPartOsc
           }
 
-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)
   where
     -- playmap is a ValueMap where the keys don't start with ^ and are not ""
@@ -210,8 +208,8 @@ toOSC busses pe osc@(OSC _ _) =
             )
       | otherwise = Nothing
     toBus n
-      | null busses = n
-      | otherwise = busses !!! n
+      | Just busses <- maybeBusses, (not . null) busses = busses !!! n
+      | otherwise = n
     busmsgs =
       map
         ( \(k, b) -> do
@@ -221,7 +219,7 @@ toOSC busses pe osc@(OSC _ _) =
             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)
@@ -312,8 +310,8 @@ playStack pMap = stack . (map psPattern) . (filter active) . Map.elems $ pMap
 hasSolo :: Map.Map k PlayState -> Bool
 hasSolo = (>= 1) . length . filter psSolo . Map.elems
 
-onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> ControlPattern -> IO ()
-onSingleTick clockConfig clockRef stateMV busMV _ globalFMV cxs listen pat = do
+onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO ()
+onSingleTick clockConfig clockRef stateMV _ globalFMV cxs pat = do
   pMapMV <-
     newMVar $
       Map.singleton
@@ -325,7 +323,7 @@ onSingleTick clockConfig clockRef stateMV busMV _ globalFMV cxs listen pat = do
               psHistory = []
             }
         )
-  Clock.clockOnce (doTick stateMV busMV pMapMV globalFMV cxs listen) clockConfig clockRef
+  Clock.clockOnce (doTick stateMV pMapMV globalFMV cxs) clockConfig clockRef
 
 -- Used for Tempo callback
 updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()

src/Sound/Tidal/Stream/Target.hs

@@ -1,10 +1,19 @@
 module Sound.Tidal.Stream.Target where
 
-import Control.Concurrent (forkOS, threadDelay)
-import Data.Maybe (fromJust, isJust)
+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 qualified Sound.Osc.Transport.Fd.Udp as O
 import Sound.Tidal.Pattern
 import Sound.Tidal.Stream.Config
@@ -32,43 +41,79 @@ 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
-            )
+            (\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))
@@ -80,21 +125,19 @@ 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)
+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
-sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg
 
 superdirtTarget :: Target
 superdirtTarget =

src/Sound/Tidal/Stream/Types.hs

@@ -11,7 +11,6 @@ import Sound.Tidal.Stream.Config
 
 data Stream = Stream
   { sConfig :: Config,
-    sBusses :: MVar [Int],
     sStateMV :: MVar ValueMap,
     -- sOutput :: MVar ControlPattern,
     sClockRef :: Clock.ClockRef,
@@ -26,7 +25,8 @@ data Cx = Cx
     cxUDP :: O.Udp,
     cxOSCs :: [OSC],
     cxAddr :: N.AddrInfo,
-    cxBusAddr :: Maybe N.AddrInfo
+    cxBusAddr :: Maybe N.AddrInfo,
+    cxBusses :: Maybe (MVar [Int])
   }
 
 data StampStyle