module Vivid.SCServer.Connection (
createSCServerConnection
, defaultConnectConfig
, defaultMessageFunction
, ignoreMessagesFunction
, SCConnectConfig(..)
, closeSCServerConnection
, ConnProtocol(..)
, getMailboxForSyncId
, getSCServerSocket
, waitForSync_io
, waitForSync_io_noGC
) where
import Vivid.OSC
import Vivid.SCServer.State
import Network.Socket (
SocketType(Datagram ), defaultProtocol, socket
, AddrInfo(..), getAddrInfo
, Socket, HostName, ServiceName, connect, close
, withSocketsDo
)
import Network.Socket.ByteString (send, recv)
import Control.Concurrent (forkIO, ThreadId, killThread)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Monad (forever)
import Data.Int (Int32)
import qualified Data.Map as Map
import Data.Monoid
createSCServerConnection :: SCConnectConfig -> IO Socket
createSCServerConnection connConfig = do
let !_ = scServerState
shouldMakeSock scServerState >>= \case
True -> do
makeSock scServerState connConfig
False -> error "Too late -- connection already established. Disconnect first."
closeSCServerConnection :: IO ()
closeSCServerConnection = do
let !_ = scServerState
ish <- atomically $ do
writeTVar (_scServerState_socketConnectStarted scServerState) False
(,) <$> tryTakeTMVar (_scServerState_socket scServerState)
<*> tryTakeTMVar (_scServerState_listener scServerState)
case ish of
(Just sock, Just listener) -> do
killThread listener
withSocketsDo $ close sock
(Nothing, Nothing) -> return ()
_ -> error "well that's weird"
data ConnProtocol
= ConnProtocol_UDP
deriving (Show, Read, Eq, Ord)
data SCConnectConfig
= SCConnectConfig {
_scConnectConfig_hostName :: HostName
, _scConnectConfig_port :: ServiceName
, _scConnectConfig_clientId :: Int32
, _scConnectConfig_connProtocol :: ConnProtocol
, _scConnectConfig_serverMessageFunction :: OSC -> IO ()
}
defaultConnectConfig :: SCConnectConfig
defaultConnectConfig = SCConnectConfig {
_scConnectConfig_hostName = "127.0.0.1"
, _scConnectConfig_port = "57110"
, _scConnectConfig_clientId = 1
, _scConnectConfig_connProtocol = ConnProtocol_UDP
, _scConnectConfig_serverMessageFunction = defaultMessageFunction
}
connectToSCServer :: SCConnectConfig -> IO (Socket, ThreadId)
connectToSCServer scConnectConfig = withSocketsDo $ do
let hostName = _scConnectConfig_hostName scConnectConfig
port = _scConnectConfig_port scConnectConfig
connType = case _scConnectConfig_connProtocol scConnectConfig of
ConnProtocol_UDP -> Datagram
(serverAddr:_) <- getAddrInfo Nothing (Just hostName) (Just port)
s <- socket (addrFamily serverAddr) connType defaultProtocol
setClientId (_scConnectConfig_clientId scConnectConfig)
connect s (addrAddress serverAddr)
listener <- forkIO $ startMailbox (_scConnectConfig_serverMessageFunction scConnectConfig) s
let firstSyncID = toEnum $ numberOfSyncIdsToDrop 2
_ <- send s $ encodeOSCBundle $ OSCBundle (Timestamp 0) [
Right $ OSC "/dumpOSC" [OSC_I 1]
, Right $ initTreeCommand
, Right $ OSC "/sync" [OSC_I firstSyncID]
]
waitForSync_io (SyncId firstSyncID)
return (s, listener)
waitForSync_io :: SyncId -> IO ()
waitForSync_io syncId = do
_ <- readMVar =<< getMailboxForSyncId syncId
atomically $ modifyTVar' (_scServerState_syncIdMailboxes scServerState) $
Map.delete syncId
waitForSync_io_noGC :: SyncId -> IO ()
waitForSync_io_noGC syncId = do
_ <- readMVar =<< getMailboxForSyncId syncId
return ()
startMailbox :: (OSC -> IO ()) -> Socket -> IO ()
startMailbox otherMessageFunction s = forever $ recv s 1024 >>= \(msg) ->
case decodeOSC msg of
OSC "/synced" [OSC_I theSyncId] -> do
syncBox <- getMailboxForSyncId (SyncId theSyncId)
tryPutMVar syncBox () >>= \case
True -> return ()
False ->
putStrLn $ "That's weird: we got the same syncId twice: " ++ show theSyncId
x -> otherMessageFunction x
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction = \case
OSC "/done" [OSC_S _] -> return ()
OSC "/done" [OSC_S _, OSC_I _] -> return ()
x -> putStrLn $ "Msg from server: " <> show x
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction _ = return ()
getMailboxForSyncId :: SyncId -> IO (MVar ())
getMailboxForSyncId syncId = do
mvarThatIMightWannaUse <- newEmptyMVar
atomically $ do
allMailboxes <- readTVar (_scServerState_syncIdMailboxes scServerState)
case Map.lookup syncId allMailboxes of
Just syncBox -> return syncBox
Nothing -> do
writeTVar (_scServerState_syncIdMailboxes scServerState)
(Map.insert syncId mvarThatIMightWannaUse allMailboxes)
return mvarThatIMightWannaUse
getSCServerSocket :: IO Socket
getSCServerSocket = getSCServerSocket' scServerState
getSCServerSocket' :: SCServerState -> IO Socket
getSCServerSocket' scServerState' = do
let !_ = scServerState'
shouldMakeSock scServerState' >>= \case
True -> do
makeSock scServerState' defaultConnectConfig
False -> atomically . readTMVar $ _scServerState_socket scServerState'
shouldMakeSock :: SCServerState -> IO Bool
shouldMakeSock serverState = atomically $ do
let theVar = _scServerState_socketConnectStarted serverState
alreadyBeingMade <- readTVar theVar
case alreadyBeingMade of
True -> return False
False -> do
writeTVar theVar True
return True
makeSock :: SCServerState -> SCConnectConfig -> IO Socket
makeSock serverState connConfig = do
(sock, listener) <- connectToSCServer connConfig
atomically $ do
True <- tryPutTMVar (_scServerState_socket serverState) sock
True <- tryPutTMVar (_scServerState_listener serverState) listener
return sock