{-# 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

   -- Exported at least for 'Vivid.GlobalState':
   , startMailbox'
   , connectToSCServer'

   -- for tests:
   , 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
   -- , AddrInfoFlag(..),
   , defaultHints
   , Socket, HostName, ServiceName, connect, close -- , listen, bind
   -- , bindSocket, accept
   , accept, listen
                                                            
    -- We put this everywhere we do socket actions for Windows compatibility:
   , 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)

-- | __You usually don't need to call this function__
-- 
--   Use this if to connect on a non-default port or to a server not at localhost
-- 
--   Otherwise the connection is created when it's needed.
--   You can also use this to explicitly create the connection, so the
--   computation is done upfront
-- 
--   The 'HostName' is the ip address or "localhost". The 'ServiceName' is the port
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 a b. IO a -> (a -> IO b) -> IO b
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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."

-- | Explicitly close Vivid's connection to a SC server.
-- 
--   Day-to-day, you can usually just let your program run without using this.
-- 
--   For example though, if you're running code that uses Vivid in ghci, and
--   you ":r", you'll want to disconnect first -- there are processes running
--   which can step on the toes of your new instance
--   (TODO: this isn't fully true - I ":r" all the time - what do I mean here?)
-- 
--   Also if you want to change the params of your connection (e.g. to connect
--   to a different server), you'll want to disconnect from the other
--   connection 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
{-
      (,) <$> swapTVar (_scServerState_socket serverState) Nothing
          <*> swapTVar (_scServerState_listener serverState) Nothing
-}
      (,) (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 a b. STM (a -> b) -> STM a -> STM b
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 a. a -> IO a
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
     -- ^ To prevent NodeId clashes when multiple clients are connected to
     --   the same server, each client should have a separate clientId, which
     --   keeps the nodeId separate. Sclang's default clientId is 0, and ours
     --   is 1, so you can run both at the same time without config.
     --   This number must be between 0 and 31
  , SCConnectConfig -> ConnProtocol
_scConnectConfig_connProtocol :: ConnProtocol
  , SCConnectConfig -> Maybe ByteString
_scConnectConfig_password :: Maybe ByteString -- TODO: I don't like that e.g. a password could be provided with UDP, which doesn't use them
  , SCConnectConfig -> OSC -> IO ()
_scConnectConfig_serverMessageFunction :: OSC -> IO ()
  -- max # of synthdefs -- and clear em out
  }
-- deriving (Show, Read, Eq)


-- | The default _scConnectConfig_clientId is 1, and sclang's is 0, so you should
--   be able to run vivid side-by-side with the SC IDE out of the box.
defaultConnectConfig :: SCConnectConfig
defaultConnectConfig :: SCConnectConfig
defaultConnectConfig = 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 -- ConnProtocol_TCP -- UDP -- TODO: not for release!
   , _scConnectConfig_password :: Maybe ByteString
_scConnectConfig_password = Maybe ByteString
forall a. Maybe a
Nothing
   , _scConnectConfig_serverMessageFunction :: OSC -> IO ()
_scConnectConfig_serverMessageFunction = OSC -> IO ()
defaultMessageFunction
   }

-- Internal -- this is what gets called after we check a socket doesn't
-- already exist:
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]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo
defaultHints { addrSocketType = connType })) {- (Just (defaultHints {addrFlags = [AI_PASSIVE]})) -} (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) -- defaultProtocol
   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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- This must be the very first message sent to the server:
      Just ByteString
password -> Socket -> ByteString -> IO ()
sendAll {- MaybePad  (_scConnectConfig_connProtocol scConnectConfig) -} 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket
s, ThreadId
listener)

-- ALWAYS use this instead of 'send':
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 -- TODO: send vs sendAll? Makes a difference?
 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
   -- We garbage-collect these so the Map stays small -- but it means you can only wait
   -- for a sync from one place:
   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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- TODO: what's "mailbox" here? Is it like an Erlang mailbox, to receive and
-- dispatch all messages?
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 -- note we only read this once at the beginning. If this can change throughout program run, update this code
   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 {- From -} Socket
s Int
65536 IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 -- From the 'network' docs: "For TCP sockets, a zero length return value means the peer has closed its half side of the connection."
               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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Bool
True -> () -> IO ()
forall a. a -> IO a
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)

-- There can be more than one message that we recieve as one binary blob:
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)



-- | Print all messages other than \"/done\"s
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction = \case
   -- Some examples you might want to handle individually:
   {-
   OSC "/fail" [OSC_S "/blah", OSC_S "Command not found"] -> pure ()
   OSC "/fail" [OSC_S "/s_new", OSC_S "wrong argument type"] -> pure ()
   OSC "/fail" [OSC_S "/b_allocRead", OSC_S "File 'blah.ogg' could not be opened: Error : flac decoder lost sync.\n",OSC_I 2]
   -}
   OSC ByteString
"/done" [OSC_S ByteString
_] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   OSC ByteString
"/done" [OSC_S ByteString
_, OSC_I Int32
_] -> () -> IO ()
forall a. a -> IO a
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

-- | If you don't want to hear what the server has to say
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction OSC
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- This is a nice example of when STM can be really helpful -
-- It's impossible! (right?) to have 2 threads create mailboxes and have em overwrite each
-- other -- so we can make a guarantee about recieving a sync that you register for
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 -- TODO: make this a TMVar so it doesn't have to sit outside like this?
   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 a. a -> STM a
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 a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar ()
mvarThatIMightWannaUse
   MVar () -> IO (MVar ())
forall a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Socket
x -> Socket -> IO Socket
forall a. a -> IO a
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 a. a -> STM a
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 a. a -> STM a
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
      -- writeTVar (_scServerState_socket serverState) $ Just sock
      -- writeTVar (_scServerState_listener serverState) $ Just listener
      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 a. a -> STM a
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 a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Socket
forall a. Maybe a
Nothing)