Connection.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE NoIncoherentInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE 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 {- , Stream -}), defaultProtocol, socket
   , AddrInfo(..), getAddrInfo
   -- , AddrInfoFlag(..), defaultHints
   , Socket, HostName, ServiceName, connect, close -- , listen, bind
   -- , bindSocket, accept
                                                            
    -- We put this everywhere we do socket actions for Windows compatibility:
   , withSocketsDo
   )

import Network.Socket.ByteString (send, recv)

import Control.Concurrent (forkIO, ThreadId, killThread)
import Control.Concurrent.MVar
import Control.Concurrent.STM -- (readTVar, modifyTVar', atomically, writeTVar, {- readTVarIO, -} swapTVar)
import Control.Monad (forever)
import Data.Int (Int32)
-- import Data.IORef
import qualified Data.Map as Map
import Data.Monoid

-- | __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 :: SCConnectConfig -> IO (Either String Socket)
createSCServerConnection connConfig = do
   let !_ = scServerState
   shouldMakeSock scServerState >>= \case
      True -> do
         Right <$> makeSock scServerState connConfig
      False ->
         pure $ Left "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 :: IO ()
closeSCServerConnection = do
   let !_ = scServerState
   ish <- atomically $ do
      writeTVar (_scServerState_socketConnectStarted scServerState) False
{-
      (,) <$> swapTVar (_scServerState_socket scServerState) Nothing
          <*> swapTVar (_scServerState_listener scServerState) Nothing
-}
      (,) <$> tryTakeTMVar (_scServerState_socket scServerState)
          <*> tryTakeTMVar (_scServerState_listener scServerState)

{-
   ish <- (,) <$> readIORef (_scServerState_socket scServerState)
              <*> readIORef (_scServerState_listener scServerState)
   writeIORef (_scServerState_socket scServerState) Nothing
   writeIORef (_scServerState_listener scServerState) Nothing
-}
   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
   -- ConnProtocol_TCP
 deriving (Show, Read, Eq, Ord)

data SCConnectConfig
   = SCConnectConfig {
    _scConnectConfig_hostName :: HostName
  , _scConnectConfig_port :: ServiceName
  , _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.
  , _scConnectConfig_connProtocol :: ConnProtocol
  , _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 {
     _scConnectConfig_hostName = "127.0.0.1"
   , _scConnectConfig_port = "57110"
   , _scConnectConfig_clientId = 1
   , _scConnectConfig_connProtocol = ConnProtocol_UDP
   , _scConnectConfig_serverMessageFunction = defaultMessageFunction
   }

-- Internal -- this is what gets called after we check a socket doesn't
-- already exist:
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
--          ConnProtocol_TCP -> Stream
   (serverAddr:_) <- getAddrInfo Nothing {- (Just (defaultHints {addrFlags = [AI_PASSIVE]})) -} (Just hostName) (Just port)
   s <- socket (addrFamily serverAddr) connType defaultProtocol
   {-
   if (connType == Stream)
      then do
         print 0
         bindSocket s (addrAddress serverAddr)
         print 1
         listen s 1
         -- _ <- accept s
         return ()
   else connect s (addrAddress serverAddr)
-}
   setClientId (_scConnectConfig_clientId scConnectConfig)
   connect s (addrAddress serverAddr)
--   accept s

   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)
   return (s, listener)

waitForSync_io :: SyncId -> IO ()
waitForSync_io syncId = do
   _ <- readMVar =<< getMailboxForSyncId syncId
   -- We garbage-collect these so the Map stays small -- but it means you can only wait
   -- for a sync from one place:
   atomically $ modifyTVar' (_scServerState_syncIdMailboxes scServerState) $
      Map.delete syncId

waitForSync_io_noGC :: SyncId -> IO ()
waitForSync_io_noGC syncId = do
   _ <- readMVar =<< getMailboxForSyncId syncId
   return ()

-- TODO: what's "mailbox" here? Is it like an Erlang mailbox, to receive and
-- dispatch all messages?
startMailbox :: Socket -> IO ()
startMailbox s = do
   let !_ = scServerState
   forever $ recv {- From -} s 65536 >>= \(msg{- , _ -}) ->
      case decodeOSC msg of
         Right (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
         Right x -> do
            otherMessageFunction <- readTVarIO $
               _scServerState_serverMessageFunction scServerState
            otherMessageFunction x
         Left e -> putStrLn $ "ERROR DECODING OSC: " ++ show (msg, e)

-- | Print all messages other than \"/done\"s
defaultMessageFunction :: OSC -> IO ()
defaultMessageFunction = \case
   -- Some examples you might want to handle individually:
   {-
   OSC "/fail" [OSC_S "/blah", OSC_S "Command not found"] -> return ()
   OSC "/fail" [OSC_S "/s_new", OSC_S "wrong argument type"] -> return ()
   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 "/done" [OSC_S _] -> return ()
   OSC "/done" [OSC_S _, OSC_I _] -> return ()
   x -> putStrLn $ "Msg from server: " <> show x

-- | If you don't want to hear what the server has to say
ignoreMessagesFunction :: OSC -> IO ()
ignoreMessagesFunction _ = return ()

-- 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 :: 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
      -- Just s -> return s
      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
            -- writeTVar (_scServerState_socket serverState) $ Just sock
            -- writeTVar (_scServerState_listener serverState) $ Just listener
            True <- tryPutTMVar (_scServerState_socket serverState) sock
            True <- tryPutTMVar (_scServerState_listener serverState) listener
            return sock