Skip to content
This repository was archived by the owner on Jun 13, 2025. It is now read-only.

Commit 619aa91

Browse files
yaxuyaxu
authored
Merge pull request #1051 from matthewkaney/split-osc-code
Split controller OSC off from SuperDirt handshake OSC (Redux for 1.9)
2 parents 493b2c0 + b61702d commit 619aa91

File tree

7 files changed

+99
-103
lines changed

7 files changed

+99
-103
lines changed

‎src/Sound/Tidal/Stream/Config.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module Sound.Tidal.Stream.Config where
22

3+
import Control.Monad (when)
34
import qualified Sound.Tidal.Clock as Clock
45

56
{-
@@ -45,3 +46,6 @@ defaultConfig =
4546
cVerbose = True,
4647
cClockConfig = Clock.defaultConfig
4748
}
49+
50+
verbose :: Config -> String -> IO ()
51+
verbose c s = when (cVerbose c) $ putStrLn s

‎src/Sound/Tidal/Stream/Listen.hs‎

Lines changed: 9 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -4,10 +4,9 @@ import Control.Concurrent.MVar
44
import qualified Control.Exception as E
55
import Control.Monad (when)
66
import qualified Data.Map as Map
7-
import Data.Maybe (catMaybes, fromJust, isJust)
7+
import Data.Maybe (fromJust)
88
import qualified Network.Socket as N
99
import qualified Sound.Osc.Fd as O
10-
import qualified Sound.Osc.Time.Timeout as O
1110
import qualified Sound.Osc.Transport.Fd.Udp as O
1211
import Sound.Tidal.ID
1312
import Sound.Tidal.Pattern
@@ -53,36 +52,15 @@ openListener c
5352
catchAny = E.catch
5453

5554
-- Listen to and act on OSC control messages
56-
ctrlResponder :: Int -> Config -> Stream -> IO ()
57-
ctrlResponder waits c (stream@(Stream {sListen = Just sock})) =
58-
do
59-
ms <- recvMessagesTimeout 2 sock
60-
if (null ms)
61-
then do
62-
checkHandshake -- there was a timeout, check handshake
63-
ctrlResponder (waits + 1) c stream
64-
else do
65-
mapM_ act ms
66-
ctrlResponder 0 c stream
55+
ctrlResponder :: Config -> Stream -> IO ()
56+
ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop
6757
where
68-
checkHandshake = do
69-
busses <- readMVar (sBusses stream)
70-
when (null busses) $ do
71-
when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."
72-
sendHandshakes stream
73-
74-
act (O.Message "/dirt/hello" _) = sendHandshakes stream
75-
act (O.Message "/dirt/handshake/reply" xs) = do
76-
prev <- swapMVar (sBusses stream) $ bufferIndices xs
77-
-- Only report the first time..
78-
when (null prev) $ verbose c $ "Connected to SuperDirt."
79-
return ()
80-
where
81-
bufferIndices [] = []
82-
bufferIndices (x : xs')
83-
| x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
84-
| otherwise = bufferIndices xs'
58+
loop :: IO ()
59+
loop = do
60+
O.recvMessages sock >>= mapM_ act
61+
loop
8562
-- External controller commands
63+
act :: O.Message -> IO ()
8664
act (O.Message "/ctrl" (O.Int32 k : v : [])) =
8765
act (O.Message "/ctrl" [O.string $ show k, v])
8866
act (O.Message "/ctrl" (O.AsciiString k : v@(O.Float _) : [])) =
@@ -132,10 +110,4 @@ ctrlResponder waits c (stream@(Stream {sListen = Just sock})) =
132110
withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k
133111
withID (O.Int32 k) func = func $ (ID . show) k
134112
withID _ _ = return ()
135-
ctrlResponder _ _ _ = return ()
136-
137-
verbose :: Config -> String -> IO ()
138-
verbose c s = when (cVerbose c) $ putStrLn s
139-
140-
recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
141-
recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
113+
ctrlResponder _ _ = return ()

‎src/Sound/Tidal/Stream/Main.hs‎

Lines changed: 3 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -5,16 +5,15 @@ import qualified Data.Map as Map
55
import qualified Sound.Tidal.Clock as Clock
66
import Sound.Tidal.Stream.Config
77
( Config (cClockConfig, cCtrlAddr, cCtrlPort),
8+
verbose,
89
)
910
import Sound.Tidal.Stream.Listen
1011
( ctrlResponder,
1112
openListener,
12-
verbose,
1313
)
1414
import Sound.Tidal.Stream.Process (doTick)
1515
import Sound.Tidal.Stream.Target (getCXs, superdirtShape)
1616
import Sound.Tidal.Stream.Types (OSC, Stream (..), Target)
17-
import Sound.Tidal.Stream.UI (sendHandshakes)
1817
import Sound.Tidal.Version (tidal_status_string)
1918
import System.IO (hPutStrLn, stderr)
2019

@@ -47,7 +46,6 @@ startStream :: Config -> [(Target, [OSC])] -> IO Stream
4746
startStream config oscmap = do
4847
sMapMV <- newMVar Map.empty
4948
pMapMV <- newMVar Map.empty
50-
bussesMV <- newMVar []
5149
globalFMV <- newMVar id
5250

5351
tidal_status_string >>= verbose config
@@ -56,12 +54,11 @@ startStream config oscmap = do
5654

5755
cxs <- getCXs config oscmap
5856

59-
clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen)
57+
clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV pMapMV globalFMV cxs)
6058

6159
let stream =
6260
Stream
6361
{ sConfig = config,
64-
sBusses = bussesMV,
6562
sStateMV = sMapMV,
6663
sClockRef = clockRef,
6764
-- sLink = abletonLink,
@@ -72,10 +69,8 @@ startStream config oscmap = do
7269
sCxs = cxs
7370
}
7471

75-
sendHandshakes stream
76-
7772
-- Spawn a thread to handle OSC control messages
78-
_ <- forkIO $ ctrlResponder 0 config stream
73+
_ <- forkIO $ ctrlResponder config stream
7974
return stream
8075

8176
startMulti :: [Target] -> Config -> IO ()

‎src/Sound/Tidal/Stream/Process.hs‎

Lines changed: 12 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -76,22 +76,19 @@ data ProcessedEvent = ProcessedEvent
7676
-- because the likely reason is that something is wrong with the current pattern.
7777
doTick ::
7878
MVar ValueMap -> -- pattern state
79-
MVar [Int] -> -- busses
8079
MVar PlayMap -> -- currently playing
8180
MVar (ControlPattern -> ControlPattern) -> -- current global fx
8281
[Cx] -> -- target addresses
83-
Maybe O.Udp -> -- network socket
8482
(Time, Time) -> -- current arc
8583
Double -> -- nudge
8684
Clock.ClockConfig -> -- config of the clock
8785
Clock.ClockRef -> -- reference to the clock
8886
(Link.SessionState, Link.SessionState) -> -- second session state is for keeping track of tempo changes
8987
IO ()
90-
doTick stateMV busMV playMV globalFMV cxs listen (st, end) nudge cconf cref (ss, temposs) =
88+
doTick stateMV playMV globalFMV cxs (st, end) nudge cconf cref (ss, temposs) =
9189
E.handle handleException $ do
9290
modifyMVar_ stateMV $ \sMap -> do
9391
pMap <- readMVar playMV
94-
busses <- readMVar busMV
9592
sGlobalF <- readMVar globalFMV
9693
bpm <- Clock.getTempo ss
9794
let patstack = sGlobalF $ playStack pMap
@@ -112,14 +109,15 @@ doTick stateMV busMV playMV globalFMV cxs listen (st, end) nudge cconf cref (ss,
112109
(sMap'', es') = resolveState sMap' es
113110
tes <- processCps cconf cref (ss, temposs) es'
114111
-- For each OSC target
115-
forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do
112+
forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do
113+
busses <- mapM readMVar bussesMV
116114
-- Latency is configurable per target.
117115
-- Latency is only used when sending events live.
118116
let latency = oLatency target
119117
ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes
120118
-- send the events to the OSC target
121119
forM_ ms $ \m ->
122-
(send listen cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
120+
(send cx latency extraLatency m) `E.catch` \(e :: E.SomeException) ->
123121
hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e
124122
return sMap''
125123
where
@@ -168,8 +166,8 @@ processCps cconf cref (ss, temposs) = mapM processEvent
168166
peOnPartOsc = onPartOsc
169167
}
170168

171-
toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
172-
toOSC busses pe osc@(OSC _ _) =
169+
toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]
170+
toOSC maybeBusses pe osc@(OSC _ _) =
173171
catMaybes (playmsg : busmsgs)
174172
where
175173
-- playmap is a ValueMap where the keys don't start with ^ and are not ""
@@ -210,8 +208,8 @@ toOSC busses pe osc@(OSC _ _) =
210208
)
211209
| otherwise = Nothing
212210
toBus n
213-
| null busses = n
214-
| otherwise = busses !!! n
211+
| Just busses <- maybeBusses, (not . null) busses = busses !!! n
212+
| otherwise = n
215213
busmsgs =
216214
map
217215
( \(k, b) -> do
@@ -221,7 +219,7 @@ toOSC busses pe osc@(OSC _ _) =
221219
return $
222220
( tsPart,
223221
True, -- bus message ?
224-
O.Message "/c_set" [O.int32 bi, toDatum v]
222+
O.Message "/c_set" [O.int32 (toBus bi), toDatum v]
225223
)
226224
)
227225
(Map.toList busmap)
@@ -312,8 +310,8 @@ playStack pMap = stack . (map psPattern) . (filter active) . Map.elems $ pMap
312310
hasSolo :: Map.Map k PlayState -> Bool
313311
hasSolo = (>= 1) . length . filter psSolo . Map.elems
314312

315-
onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> ControlPattern -> IO ()
316-
onSingleTick clockConfig clockRef stateMV busMV _ globalFMV cxs listen pat = do
313+
onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO ()
314+
onSingleTick clockConfig clockRef stateMV _ globalFMV cxs pat = do
317315
pMapMV <-
318316
newMVar $
319317
Map.singleton
@@ -325,7 +323,7 @@ onSingleTick clockConfig clockRef stateMV busMV _ globalFMV cxs listen pat = do
325323
psHistory = []
326324
}
327325
)
328-
Clock.clockOnce (doTick stateMV busMV pMapMV globalFMV cxs listen) clockConfig clockRef
326+
Clock.clockOnce (doTick stateMV pMapMV globalFMV cxs) clockConfig clockRef
329327

330328
-- Used for Tempo callback
331329
updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()

‎src/Sound/Tidal/Stream/Target.hs‎

Lines changed: 68 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,19 @@
11
module Sound.Tidal.Stream.Target where
22

3-
import Control.Concurrent (forkOS, threadDelay)
4-
import Data.Maybe (fromJust, isJust)
3+
import Control.Concurrent
4+
( forkIO,
5+
forkOS,
6+
newMVar,
7+
readMVar,
8+
swapMVar,
9+
threadDelay,
10+
)
11+
import Control.Monad (when)
12+
import Data.Maybe (catMaybes, fromJust, isJust)
513
import Foreign (Word8)
614
import qualified Network.Socket as N
715
import qualified Sound.Osc.Fd as O
16+
import qualified Sound.Osc.Time.Timeout as O
817
import qualified Sound.Osc.Transport.Fd.Udp as O
918
import Sound.Tidal.Pattern
1019
import Sound.Tidal.Stream.Config
@@ -32,43 +41,79 @@ getCXs :: Config -> [(Target, [OSC])] -> IO [Cx]
3241
getCXs config oscmap =
3342
mapM
3443
( \(target, os) -> do
35-
remote_addr <- resolve (oAddress target) (show $ oPort target)
36-
remote_bus_addr <-
37-
if isJust $ oBusPort target
38-
then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target)
39-
else return Nothing
44+
remote_addr <- resolve (oAddress target) (oPort target)
45+
remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target)
46+
remote_busses <- sequence (oBusPort target >> Just (newMVar []))
47+
4048
let broadcast = if cCtrlBroadcast config then 1 else 0
4149
u <-
4250
O.udp_socket
43-
( \sock sockaddr -> do
44-
N.setSocketOption sock N.Broadcast broadcast
45-
N.connect sock sockaddr
46-
)
51+
(\sock _ -> do N.setSocketOption sock N.Broadcast broadcast)
4752
(oAddress target)
4853
(oPort target)
49-
return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os}
54+
let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os}
55+
_ <- forkIO $ handshake cx config
56+
return cx
5057
)
5158
oscmap
5259

53-
resolve :: String -> String -> IO N.AddrInfo
60+
resolve :: String -> Int -> IO N.AddrInfo
5461
resolve host port = do
5562
let hints = N.defaultHints {N.addrSocketType = N.Stream}
56-
addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just port)
63+
addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port)
5764
return addr
5865

66+
handshake :: Cx -> Config -> IO ()
67+
handshake Cx {cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr} c = sendHandshake >> listen 0
68+
where
69+
sendHandshake :: IO ()
70+
sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr)
71+
listen :: Int -> IO ()
72+
listen waits = do
73+
ms <- recvMessagesTimeout 2 udp
74+
if null ms
75+
then do
76+
checkHandshake waits -- there was a timeout, check handshake
77+
listen (waits + 1)
78+
else do
79+
mapM_ respond ms
80+
listen 0
81+
checkHandshake :: Int -> IO ()
82+
checkHandshake waits = do
83+
busses <- readMVar bussesMV
84+
when (null busses) $ do
85+
when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."
86+
sendHandshake
87+
respond :: O.Message -> IO ()
88+
respond (O.Message "/dirt/hello" _) = sendHandshake
89+
respond (O.Message "/dirt/handshake/reply" xs) = do
90+
prev <- swapMVar bussesMV $ bufferIndices xs
91+
-- Only report the first time..
92+
when (null prev) $ verbose c $ "Connected to SuperDirt."
93+
respond _ = return ()
94+
bufferIndices :: [O.Datum] -> [Int]
95+
bufferIndices [] = []
96+
bufferIndices (x : xs')
97+
| x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
98+
| otherwise = bufferIndices xs'
99+
handshake _ _ = return ()
100+
101+
recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]
102+
recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock
103+
59104
-- send has three modes:
60105
-- Send events early using timestamp in the OSC bundle - used by Superdirt
61106
-- Send events early by adding timestamp to the OSC message - used by Dirt
62107
-- Send events live by delaying the thread
63-
send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
64-
send listen cx latency extraLatency (time, isBusMsg, m)
65-
| oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m]
66-
| oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m
108+
send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()
109+
send cx latency extraLatency (time, isBusMsg, m)
110+
| oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m]
111+
| oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m
67112
| otherwise = do
68113
_ <- forkOS $ do
69114
now <- O.time
70115
threadDelay $ floor $ (timeWithLatency - now) * 1000000
71-
sendO isBusMsg listen cx m
116+
sendO isBusMsg cx m
72117
return ()
73118
where
74119
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)
80125
target = cxTarget cx
81126
timeWithLatency = time - latency + extraLatency
82127

83-
sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO ()
84-
sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr)
128+
sendBndl :: Bool -> Cx -> O.Bundle -> IO ()
129+
sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr)
85130
where
86131
addr
87132
| isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
88133
| otherwise = cxAddr cx
89-
sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl
90134

91-
sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO ()
92-
sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr)
135+
sendO :: Bool -> Cx -> O.Message -> IO ()
136+
sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr)
93137
where
94138
addr
95139
| isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx
96140
| otherwise = cxAddr cx
97-
sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg
98141

99142
superdirtTarget :: Target
100143
superdirtTarget =

‎src/Sound/Tidal/Stream/Types.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ import Sound.Tidal.Stream.Config
1111

1212
data Stream = Stream
1313
{ sConfig :: Config,
14-
sBusses :: MVar [Int],
1514
sStateMV :: MVar ValueMap,
1615
-- sOutput :: MVar ControlPattern,
1716
sClockRef :: Clock.ClockRef,
@@ -26,7 +25,8 @@ data Cx = Cx
2625
cxUDP :: O.Udp,
2726
cxOSCs :: [OSC],
2827
cxAddr :: N.AddrInfo,
29-
cxBusAddr :: Maybe N.AddrInfo
28+
cxBusAddr :: Maybe N.AddrInfo,
29+
cxBusses :: Maybe (MVar [Int])
3030
}
3131

3232
data StampStyle

0 commit comments

Comments
 (0)