{-# LANGUAGE
BangPatterns
, LambdaCase
, OverloadedStrings
, NoIncoherentInstances
, NoMonomorphismRestriction
, NoUndecidableInstances
#-}
module Vivid.SCServer.Connection (
createSCServerConnection
, defaultConnectConfig
, defaultMessageFunction
, ignoreMessagesFunction
, SCConnectConfig(..)
, closeSCServerConnection
, ConnProtocol(..)
, getMailboxForSyncId
, getSCServerSocket
, waitForSync_io
, waitForSync_io_noGC
) where
import Vivid.SC.Server.Commands as SCCmd
import Vivid.OSC
import Vivid.OSC.Bundles (initTreeCommand)
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 (Either String Socket)
createSCServerConnection connConfig = do
let !_ = scServerState
shouldMakeSock scServerState >>= \case
True -> makeSock scServerState connConfig >>= \case
Just s -> pure $ Right s
Nothing -> pure $ Left "Unable to create socket"
False ->
pure $ Left "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) -> pure ()
_ -> 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 !_ = scServerState
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)
atomically $ writeTVar (_scServerState_serverMessageFunction scServerState) $
_scConnectConfig_serverMessageFunction scConnectConfig
listener <- forkIO $ startMailbox s
let firstSyncID = toEnum $ numberOfSyncIdsToDrop - 2
_ <- send s $ encodeOSCBundle $ OSCBundle (Timestamp 0) [
Right $ SCCmd.dumpOSC DumpOSC_Parsed
, Right $ initTreeCommand
, Right $ SCCmd.sync (SyncId firstSyncID)
]
waitForSync_io (SyncId firstSyncID)
pure (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
pure ()
startMailbox :: Socket -> IO ()
startMailbox s = do
let !_ = scServerState
forever $ recv s 65536 >>= \(msg) ->
case decodeOSC msg of
Right (OSC "/synced" [OSC_I theSyncId]) -> do
syncBox <- getMailboxForSyncId (SyncId theSyncId)
tryPutMVar syncBox () >>= \case
True -> pure ()
False ->
putStrLn $
"That's weird!: we got the same syncId twice: "
++ show theSyncId
Right x -> do
otherMessageFunction <- readTVarIO $
_scServerState_serverMessageFunction scServerState
otherMessageFunction x
Left e -> putStrLn $ "ERROR DECODING OSC: " ++ show (msg, e)
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction = \case
OSC "/done" [OSC_S _] -> pure ()
OSC "/done" [OSC_S _, OSC_I _] -> pure ()
x -> putStrLn $ "Msg from server: " <> show x
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction _ = pure ()
getMailboxForSyncId :: SyncId -> IO (MVar ())
getMailboxForSyncId syncId = do
mvarThatIMightWannaUse <- newEmptyMVar
atomically $ do
allMailboxes <- readTVar (_scServerState_syncIdMailboxes scServerState)
case Map.lookup syncId allMailboxes of
Just syncBox -> pure syncBox
Nothing -> do
writeTVar (_scServerState_syncIdMailboxes scServerState)
(Map.insert syncId mvarThatIMightWannaUse allMailboxes)
pure mvarThatIMightWannaUse
getSCServerSocket :: IO Socket
getSCServerSocket = getSCServerSocket' scServerState
getSCServerSocket' :: SCServerState -> IO Socket
getSCServerSocket' scServerState' = do
let !_ = scServerState'
shouldMakeSock scServerState' >>= \case
True -> do
makeSock scServerState' defaultConnectConfig >>= \case
Just x -> pure x
Nothing -> error "Unexpected failure creating socket"
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 -> pure False
False -> do
writeTVar theVar True
pure True
makeSock :: SCServerState -> SCConnectConfig -> IO (Maybe Socket)
makeSock serverState connConfig = do
(sock, listener) <- connectToSCServer connConfig
atomically $ (do
a <- tryPutTMVar (_scServerState_socket serverState) sock
b <- tryPutTMVar (_scServerState_listener serverState) listener
check $ a && b
pure $ Just sock)
`orElse` (pure Nothing)