{-# LANGUAGE
BangPatterns
, LambdaCase
, OverloadedStrings
, ViewPatterns
, NoIncoherentInstances
, NoMonomorphismRestriction
, NoUndecidableInstances
#-}
module Vivid.SCServer.Connection (
createSCServerConnection'
, defaultConnectConfig
, defaultMessageFunction
, ignoreMessagesFunction
, SCConnectConfig(..)
, closeSCServerConnection'
, ConnProtocol(..)
, getMailboxForSyncId'
, getSCServerSocket'
, waitForSync_io'
, waitForSync_io_noGC'
, sendMaybePad
, startMailbox'
, connectToSCServer'
, splitMessagesFromChunk
) 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 , Stream), defaultProtocol, socket
, AddrInfo(..), getAddrInfo
, defaultHints
, Socket, HostName, ServiceName, connect, close
, accept, listen
, withSocketsDo
)
import Network.Socket.ByteString (sendAll, recv)
import Control.Concurrent (forkIO, ThreadId, killThread)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Monad (forever)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Int (Int32)
import qualified Data.Map as Map
import Data.Monoid
import Data.Serialize (encode, decode)
createSCServerConnection' :: SCServerState -> SCConnectConfig -> IO (Either String Socket)
createSCServerConnection' :: SCServerState -> SCConnectConfig -> IO (Either String Socket)
createSCServerConnection' SCServerState
serverState SCConnectConfig
connConfig = do
let !SCServerState
_ = SCServerState
serverState
SCServerState -> IO Bool
shouldMakeSock SCServerState
serverState IO Bool
-> (Bool -> IO (Either String Socket)) -> IO (Either String Socket)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> SCServerState -> SCConnectConfig -> IO (Maybe Socket)
makeSock SCServerState
serverState SCConnectConfig
connConfig IO (Maybe Socket)
-> (Maybe Socket -> IO (Either String Socket))
-> IO (Either String Socket)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Socket
s -> Either String Socket -> IO (Either String Socket)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Socket -> IO (Either String Socket))
-> Either String Socket -> IO (Either String Socket)
forall a b. (a -> b) -> a -> b
$ Socket -> Either String Socket
forall a b. b -> Either a b
Right Socket
s
Maybe Socket
Nothing -> Either String Socket -> IO (Either String Socket)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Socket -> IO (Either String Socket))
-> Either String Socket -> IO (Either String Socket)
forall a b. (a -> b) -> a -> b
$ String -> Either String Socket
forall a b. a -> Either a b
Left String
"Unable to create socket"
Bool
False ->
Either String Socket -> IO (Either String Socket)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Socket -> IO (Either String Socket))
-> Either String Socket -> IO (Either String Socket)
forall a b. (a -> b) -> a -> b
$ String -> Either String Socket
forall a b. a -> Either a b
Left String
"Too late -- connection already established. Disconnect first."
closeSCServerConnection' :: SCServerState -> IO ()
closeSCServerConnection' :: SCServerState -> IO ()
closeSCServerConnection' SCServerState
serverState = do
let !SCServerState
_ = SCServerState
serverState
(Maybe Socket, Maybe ThreadId)
ish <- STM (Maybe Socket, Maybe ThreadId)
-> IO (Maybe Socket, Maybe ThreadId)
forall a. STM a -> IO a
atomically (STM (Maybe Socket, Maybe ThreadId)
-> IO (Maybe Socket, Maybe ThreadId))
-> STM (Maybe Socket, Maybe ThreadId)
-> IO (Maybe Socket, Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ do
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (SCServerState -> TVar Bool
_scServerState_socketConnectStarted SCServerState
serverState) Bool
False
(,) (Maybe Socket -> Maybe ThreadId -> (Maybe Socket, Maybe ThreadId))
-> STM (Maybe Socket)
-> STM (Maybe ThreadId -> (Maybe Socket, Maybe ThreadId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar Socket -> STM (Maybe Socket)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (SCServerState -> TMVar Socket
_scServerState_socket SCServerState
serverState)
STM (Maybe ThreadId -> (Maybe Socket, Maybe ThreadId))
-> STM (Maybe ThreadId) -> STM (Maybe Socket, Maybe ThreadId)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TMVar ThreadId -> STM (Maybe ThreadId)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (SCServerState -> TMVar ThreadId
_scServerState_listener SCServerState
serverState)
case (Maybe Socket, Maybe ThreadId)
ish of
(Just Socket
sock, Just ThreadId
listener) -> do
ThreadId -> IO ()
killThread ThreadId
listener
IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
close Socket
sock
(Maybe Socket
Nothing, Maybe ThreadId
Nothing) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Maybe Socket, Maybe ThreadId)
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"well that's weird"
data SCConnectConfig
= SCConnectConfig {
SCConnectConfig -> String
_scConnectConfig_hostName :: HostName
, SCConnectConfig -> String
_scConnectConfig_port :: ServiceName
, SCConnectConfig -> Int32
_scConnectConfig_clientId :: Int32
, SCConnectConfig -> ConnProtocol
_scConnectConfig_connProtocol :: ConnProtocol
, SCConnectConfig -> Maybe ByteString
_scConnectConfig_password :: Maybe ByteString
, SCConnectConfig -> OSC -> IO ()
_scConnectConfig_serverMessageFunction :: OSC -> IO ()
}
defaultConnectConfig :: SCConnectConfig
defaultConnectConfig :: SCConnectConfig
defaultConnectConfig = SCConnectConfig :: String
-> String
-> Int32
-> ConnProtocol
-> Maybe ByteString
-> (OSC -> IO ())
-> SCConnectConfig
SCConnectConfig {
_scConnectConfig_hostName :: String
_scConnectConfig_hostName = String
"127.0.0.1"
, _scConnectConfig_port :: String
_scConnectConfig_port = String
"57110"
, _scConnectConfig_clientId :: Int32
_scConnectConfig_clientId = Int32
1
, _scConnectConfig_connProtocol :: ConnProtocol
_scConnectConfig_connProtocol = ConnProtocol
ConnProtocol_UDP
, _scConnectConfig_password :: Maybe ByteString
_scConnectConfig_password = Maybe ByteString
forall a. Maybe a
Nothing
, _scConnectConfig_serverMessageFunction :: OSC -> IO ()
_scConnectConfig_serverMessageFunction = OSC -> IO ()
defaultMessageFunction
}
connectToSCServer' :: SCServerState -> SCConnectConfig -> IO (Socket, ThreadId)
connectToSCServer' :: SCServerState -> SCConnectConfig -> IO (Socket, ThreadId)
connectToSCServer' SCServerState
serverState SCConnectConfig
scConnectConfig = IO (Socket, ThreadId) -> IO (Socket, ThreadId)
forall a. IO a -> IO a
withSocketsDo (IO (Socket, ThreadId) -> IO (Socket, ThreadId))
-> IO (Socket, ThreadId) -> IO (Socket, ThreadId)
forall a b. (a -> b) -> a -> b
$ do
let !SCServerState
_ = SCServerState
serverState
let hostName :: String
hostName = SCConnectConfig -> String
_scConnectConfig_hostName SCConnectConfig
scConnectConfig
port :: String
port = SCConnectConfig -> String
_scConnectConfig_port SCConnectConfig
scConnectConfig
connType :: SocketType
connType = case SCConnectConfig -> ConnProtocol
_scConnectConfig_connProtocol SCConnectConfig
scConnectConfig of
ConnProtocol
ConnProtocol_UDP -> SocketType
Datagram
ConnProtocol
ConnProtocol_TCP -> SocketType
Stream
(AddrInfo
serverAddr:[AddrInfo]
_) <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo
defaultHints { addrSocketType :: SocketType
addrSocketType = SocketType
connType })) (String -> Maybe String
forall a. a -> Maybe a
Just String
hostName) (String -> Maybe String
forall a. a -> Maybe a
Just String
port)
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
serverAddr) SocketType
connType (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
serverAddr)
SCServerState -> Int32 -> IO ()
setServerClientId SCServerState
serverState (SCConnectConfig -> Int32
_scConnectConfig_clientId SCConnectConfig
scConnectConfig)
Socket -> SockAddr -> IO ()
connect Socket
s (AddrInfo -> SockAddr
addrAddress AddrInfo
serverAddr)
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TVar (OSC -> IO ()) -> (OSC -> IO ()) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (SCServerState -> TVar (OSC -> IO ())
_scServerState_serverMessageFunction SCServerState
serverState) ((OSC -> IO ()) -> STM ()) -> (OSC -> IO ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
SCConnectConfig -> OSC -> IO ()
_scConnectConfig_serverMessageFunction SCConnectConfig
scConnectConfig
TVar ConnProtocol -> ConnProtocol -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (SCServerState -> TVar ConnProtocol
_scServerState_connProtocol SCServerState
serverState) (ConnProtocol -> STM ()) -> ConnProtocol -> STM ()
forall a b. (a -> b) -> a -> b
$
SCConnectConfig -> ConnProtocol
_scConnectConfig_connProtocol SCConnectConfig
scConnectConfig
case SCConnectConfig -> Maybe ByteString
_scConnectConfig_password SCConnectConfig
scConnectConfig of
Maybe ByteString
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just ByteString
password -> Socket -> ByteString -> IO ()
sendAll Socket
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
password
ThreadId
listener <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ SCServerState -> Socket -> IO ()
startMailbox' SCServerState
serverState Socket
s
let firstSyncID :: a
firstSyncID = Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Int
numberOfSyncIdsToDrop Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
()
_ <- ConnProtocol -> Socket -> ByteString -> IO ()
sendMaybePad (SCConnectConfig -> ConnProtocol
_scConnectConfig_connProtocol SCConnectConfig
scConnectConfig) Socket
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
OSCBundle -> ByteString
encodeOSCBundle (OSCBundle -> ByteString) -> OSCBundle -> ByteString
forall a b. (a -> b) -> a -> b
$ Timestamp -> [Either ByteString OSC] -> OSCBundle
OSCBundle (Double -> Timestamp
Timestamp Double
0) [
OSC -> Either ByteString OSC
forall a b. b -> Either a b
Right (OSC -> Either ByteString OSC) -> OSC -> Either ByteString OSC
forall a b. (a -> b) -> a -> b
$ DumpOSCMode -> OSC
SCCmd.dumpOSC DumpOSCMode
DumpOSC_Parsed
, OSC -> Either ByteString OSC
forall a b. b -> Either a b
Right (OSC -> Either ByteString OSC) -> OSC -> Either ByteString OSC
forall a b. (a -> b) -> a -> b
$ OSC
initTreeCommand
, OSC -> Either ByteString OSC
forall a b. b -> Either a b
Right (OSC -> Either ByteString OSC) -> OSC -> Either ByteString OSC
forall a b. (a -> b) -> a -> b
$ SyncId -> OSC
SCCmd.sync (Int32 -> SyncId
SyncId Int32
forall a. Enum a => a
firstSyncID)
]
SCServerState -> SyncId -> IO ()
waitForSync_io' SCServerState
serverState (Int32 -> SyncId
SyncId Int32
forall a. Enum a => a
firstSyncID)
(Socket, ThreadId) -> IO (Socket, ThreadId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket
s, ThreadId
listener)
sendMaybePad :: ConnProtocol -> Socket -> ByteString -> IO ()
sendMaybePad :: ConnProtocol -> Socket -> ByteString -> IO ()
sendMaybePad ConnProtocol
connProtocol Socket
socket ByteString
msg_noPad =
IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
socket ByteString
msg
where
msg :: ByteString
msg :: ByteString
msg = case ConnProtocol
connProtocol of
ConnProtocol
ConnProtocol_UDP -> ByteString
msg_noPad
ConnProtocol
ConnProtocol_TCP -> (Int32 -> ByteString
forall a. Serialize a => a -> ByteString
encode (Int -> Int32
forall a. Enum a => Int -> a
toEnum (ByteString -> Int
BS.length ByteString
msg_noPad) :: Int32))ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>ByteString
msg_noPad
waitForSync_io' :: SCServerState -> SyncId -> IO ()
waitForSync_io' :: SCServerState -> SyncId -> IO ()
waitForSync_io' SCServerState
serverState SyncId
syncId = do
()
_ <- MVar () -> IO ()
forall a. MVar a -> IO a
readMVar (MVar () -> IO ()) -> IO (MVar ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SCServerState -> SyncId -> IO (MVar ())
getMailboxForSyncId' SCServerState
serverState SyncId
syncId
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map SyncId (MVar ()))
-> (Map SyncId (MVar ()) -> Map SyncId (MVar ())) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (SCServerState -> TVar (Map SyncId (MVar ()))
_scServerState_syncIdMailboxes SCServerState
serverState) ((Map SyncId (MVar ()) -> Map SyncId (MVar ())) -> STM ())
-> (Map SyncId (MVar ()) -> Map SyncId (MVar ())) -> STM ()
forall a b. (a -> b) -> a -> b
$
SyncId -> Map SyncId (MVar ()) -> Map SyncId (MVar ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete SyncId
syncId
waitForSync_io_noGC' :: SCServerState -> SyncId -> IO ()
waitForSync_io_noGC' :: SCServerState -> SyncId -> IO ()
waitForSync_io_noGC' SCServerState
serverState SyncId
syncId = do
()
_ <- MVar () -> IO ()
forall a. MVar a -> IO a
readMVar (MVar () -> IO ()) -> IO (MVar ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SCServerState -> SyncId -> IO (MVar ())
getMailboxForSyncId' SCServerState
serverState SyncId
syncId
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
startMailbox' :: SCServerState -> Socket -> IO ()
startMailbox' :: SCServerState -> Socket -> IO ()
startMailbox' SCServerState
serverState Socket
s = do
let !SCServerState
_ = SCServerState
serverState
ConnProtocol
connProtocol <- TVar ConnProtocol -> IO ConnProtocol
forall a. TVar a -> IO a
readTVarIO (TVar ConnProtocol -> IO ConnProtocol)
-> TVar ConnProtocol -> IO ConnProtocol
forall a b. (a -> b) -> a -> b
$ SCServerState -> TVar ConnProtocol
_scServerState_connProtocol SCServerState
serverState :: IO ConnProtocol
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO ByteString
recv Socket
s Int
65536 IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(ByteString
msg_maybePad ) -> do
case ConnProtocol
connProtocol of
ConnProtocol
ConnProtocol_UDP ->
ByteString -> IO ()
handleMsg ByteString
msg_maybePad
ConnProtocol
ConnProtocol_TCP -> do
case ByteString -> Either String [ByteString]
splitMessagesFromChunk ByteString
msg_maybePad of
Right [] -> String -> IO ()
forall a. String -> a
errorWithoutStackTrace String
"Connection to the SC server lost. Probably the server has quit or the network is down. You will need to reconnect."
Left String
err -> String -> IO ()
putStrLn String
err
Right [ByteString]
msgs ->
(ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
handleMsg [ByteString]
msgs
where
handleMsg :: ByteString -> IO ()
handleMsg :: ByteString -> IO ()
handleMsg ByteString
msg = do
case ByteString -> Either String OSC
decodeOSC ByteString
msg of
Right (OSC ByteString
"/synced" [OSC_I Int32
theSyncId]) -> do
MVar ()
syncBox <- SCServerState -> SyncId -> IO (MVar ())
getMailboxForSyncId' SCServerState
serverState (Int32 -> SyncId
SyncId Int32
theSyncId)
MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
syncBox () IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool
False ->
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"That's weird!: we got the same syncId twice: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
theSyncId
Right OSC
x -> do
OSC -> IO ()
otherMessageFunction <- TVar (OSC -> IO ()) -> IO (OSC -> IO ())
forall a. TVar a -> IO a
readTVarIO (TVar (OSC -> IO ()) -> IO (OSC -> IO ()))
-> TVar (OSC -> IO ()) -> IO (OSC -> IO ())
forall a b. (a -> b) -> a -> b
$
SCServerState -> TVar (OSC -> IO ())
_scServerState_serverMessageFunction SCServerState
serverState
OSC -> IO ()
otherMessageFunction OSC
x
Left String
e -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ERROR DECODING OSC: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ByteString, String) -> String
forall a. Show a => a -> String
show (ByteString
msg, String
e)
splitMessagesFromChunk :: ByteString -> Either String [ByteString]
splitMessagesFromChunk :: ByteString -> Either String [ByteString]
splitMessagesFromChunk ByteString
b =
case Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
4 ByteString
b of
(ByteString
"", ByteString
"") -> [ByteString] -> Either String [ByteString]
forall a b. b -> Either a b
Right []
(ByteString
sizeBS, ByteString
rest) ->
case ByteString -> Either String Int32
forall a. Serialize a => ByteString -> Either String a
decode ByteString
sizeBS :: Either String Int32 of
Left String
e -> String -> Either String [ByteString]
forall a b. a -> Either a b
Left (String -> Either String [ByteString])
-> String -> Either String [ByteString]
forall a b. (a -> b) -> a -> b
$ String
"ERROR DECODING OSC PAD: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ByteString -> String
forall a. Show a => a -> String
show ByteString
b
Right (Int32 -> Int
forall a. Enum a => a -> Int
fromEnum -> Int
size) ->
let (ByteString
thisChunk, ByteString
nextBS) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
size ByteString
rest
in case ByteString -> Int
BS.length ByteString
thisChunk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size of
Bool
False -> String -> Either String [ByteString]
forall a b. a -> Either a b
Left (String -> Either String [ByteString])
-> String -> Either String [ByteString]
forall a b. (a -> b) -> a -> b
$ String
"INCORRECT SIZE: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ByteString -> String
forall a. Show a => a -> String
show ByteString
b
Bool
True ->
case ByteString -> Either String [ByteString]
splitMessagesFromChunk ByteString
nextBS of
Left String
e -> String -> Either String [ByteString]
forall a b. a -> Either a b
Left String
e
Right [ByteString]
allRest -> [ByteString] -> Either String [ByteString]
forall a b. b -> Either a b
Right (ByteString
thisChunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
allRest)
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction = \case
OSC ByteString
"/done" [OSC_S ByteString
_] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
OSC ByteString
"/done" [OSC_S ByteString
_, OSC_I Int32
_] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
OSC
x -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Msg from server: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> OSC -> String
forall a. Show a => a -> String
show OSC
x
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction OSC
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getMailboxForSyncId' :: SCServerState -> SyncId -> IO (MVar ())
getMailboxForSyncId' :: SCServerState -> SyncId -> IO (MVar ())
getMailboxForSyncId' SCServerState
serverState SyncId
syncId = do
MVar ()
mvarThatIMightWannaUse <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ()
m <- STM (MVar ()) -> IO (MVar ())
forall a. STM a -> IO a
atomically (STM (MVar ()) -> IO (MVar ())) -> STM (MVar ()) -> IO (MVar ())
forall a b. (a -> b) -> a -> b
$ do
Map SyncId (MVar ())
allMailboxes <- TVar (Map SyncId (MVar ())) -> STM (Map SyncId (MVar ()))
forall a. TVar a -> STM a
readTVar (SCServerState -> TVar (Map SyncId (MVar ()))
_scServerState_syncIdMailboxes SCServerState
serverState)
case SyncId -> Map SyncId (MVar ()) -> Maybe (MVar ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SyncId
syncId Map SyncId (MVar ())
allMailboxes of
Just MVar ()
syncBox -> MVar () -> STM (MVar ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar ()
syncBox
Maybe (MVar ())
Nothing -> do
TVar (Map SyncId (MVar ())) -> Map SyncId (MVar ()) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (SCServerState -> TVar (Map SyncId (MVar ()))
_scServerState_syncIdMailboxes SCServerState
serverState)
(SyncId -> MVar () -> Map SyncId (MVar ()) -> Map SyncId (MVar ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SyncId
syncId MVar ()
mvarThatIMightWannaUse Map SyncId (MVar ())
allMailboxes)
MVar () -> STM (MVar ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar ()
mvarThatIMightWannaUse
MVar () -> IO (MVar ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar ()
m
getSCServerSocket' :: SCServerState -> IO Socket
getSCServerSocket' :: SCServerState -> IO Socket
getSCServerSocket' SCServerState
scServerState' = do
let !SCServerState
_ = SCServerState
scServerState'
SCServerState -> IO Bool
shouldMakeSock SCServerState
scServerState' IO Bool -> (Bool -> IO Socket) -> IO Socket
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
SCServerState -> SCConnectConfig -> IO (Maybe Socket)
makeSock SCServerState
scServerState' SCConnectConfig
defaultConnectConfig IO (Maybe Socket) -> (Maybe Socket -> IO Socket) -> IO Socket
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Socket
x -> Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
x
Maybe Socket
Nothing -> String -> IO Socket
forall a. HasCallStack => String -> a
error String
"Unexpected failure creating socket"
Bool
False -> STM Socket -> IO Socket
forall a. STM a -> IO a
atomically (STM Socket -> IO Socket)
-> (TMVar Socket -> STM Socket) -> TMVar Socket -> IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Socket -> STM Socket
forall a. TMVar a -> STM a
readTMVar (TMVar Socket -> IO Socket) -> TMVar Socket -> IO Socket
forall a b. (a -> b) -> a -> b
$ SCServerState -> TMVar Socket
_scServerState_socket SCServerState
scServerState'
shouldMakeSock :: SCServerState -> IO Bool
shouldMakeSock :: SCServerState -> IO Bool
shouldMakeSock SCServerState
serverState = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
let theVar :: TVar Bool
theVar = SCServerState -> TVar Bool
_scServerState_socketConnectStarted SCServerState
serverState
Bool
alreadyBeingMade <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
theVar
case Bool
alreadyBeingMade of
Bool
True -> Bool -> STM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Bool
False -> do
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
theVar Bool
True
Bool -> STM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
makeSock :: SCServerState -> SCConnectConfig -> IO (Maybe Socket)
makeSock :: SCServerState -> SCConnectConfig -> IO (Maybe Socket)
makeSock SCServerState
serverState SCConnectConfig
connConfig = do
(Socket
sock, ThreadId
listener) <- SCServerState -> SCConnectConfig -> IO (Socket, ThreadId)
connectToSCServer' SCServerState
serverState SCConnectConfig
connConfig
STM (Maybe Socket) -> IO (Maybe Socket)
forall a. STM a -> IO a
atomically (STM (Maybe Socket) -> IO (Maybe Socket))
-> STM (Maybe Socket) -> IO (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ (do
Bool
a <- TMVar Socket -> Socket -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar (SCServerState -> TMVar Socket
_scServerState_socket SCServerState
serverState) Socket
sock
Bool
b <- TMVar ThreadId -> ThreadId -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar (SCServerState -> TMVar ThreadId
_scServerState_listener SCServerState
serverState) ThreadId
listener
Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
&& Bool
b
Maybe Socket -> STM (Maybe Socket)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Socket -> STM (Maybe Socket))
-> Maybe Socket -> STM (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock)
STM (Maybe Socket) -> STM (Maybe Socket) -> STM (Maybe Socket)
forall a. STM a -> STM a -> STM a
`orElse` (Maybe Socket -> STM (Maybe Socket)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Socket
forall a. Maybe a
Nothing)