module Eventloop.Module.Websocket.Canvas.Canvas where
import Control.Concurrent.MVar
import Control.Concurrent
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
import Eventloop.Utility.Config
import Eventloop.Types.EventTypes
import Eventloop.Module.Websocket.Canvas.Types
import Eventloop.Module.Websocket.Canvas.JSONEncoding
import qualified Eventloop.Utility.Websockets as WS
defaultCanvasModuleConfiguration :: EventloopModuleConfiguration
defaultCanvasModuleConfiguration = ( EventloopModuleConfiguration
canvasModuleIdentifier
defaultCanvasModuleIOState
(Just canvasInitializer)
(Just canvasEventRetriever)
Nothing
Nothing
(Just canvasTeardown)
(Just canvasEventSender)
)
defaultCanvasModuleIOState :: IOState
defaultCanvasModuleIOState = CanvasState undefined undefined undefined undefined undefined undefined
canvasModuleIdentifier :: EventloopModuleIdentifier
canvasModuleIdentifier = "canvas"
canvasInitializer :: Initializer
canvasInitializer sharedIO _ = do
(comRecvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress canvasPort
userRecvBuffer <- newMVar []
sysRecvBuffer <- newEmptyMVar
routerThreadId <- forkIO (router comRecvBuffer userRecvBuffer sysRecvBuffer)
return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientConn serverSock routerThreadId)
canvasEventRetriever :: EventRetriever
canvasEventRetriever sharedIO canvasState = do
let
userRecvBuffer = canvasUserReceiveBuffer canvasState
messages <- takeMVar userRecvBuffer
putMVar userRecvBuffer []
return (sharedIO, canvasState, (map InCanvas messages))
canvasEventSender :: EventSender
canvasEventSender sharedIO canvasState (OutCanvas canvasOut) = do
let
conn = clientConnection canvasState
sendRoutedMessageOut conn (OutUserCanvas canvasOut)
return (sharedIO, canvasState)
canvasTeardown :: Teardown
canvasTeardown sharedIO canvasState = do
WS.closeWebsocketConnection (serverSocket canvasState) (clientConnection canvasState)
killThread (routerThreadId canvasState)
return (sharedIO, canvasState)
sendRoutedMessageOut :: WS.Connection -> RoutedMessageOut -> IO ()
sendRoutedMessageOut conn out = WS.writeMessage conn $ LBS.unpack $ encode out
router :: WS.ReceiveBuffer -> CanvasUserReceiveBuffer -> CanvasSystemReceiveBuffer -> IO ()
router comRecvBuffer userRecvBuffer sysRecvBuffer = do
encodedRoutedIn <- takeMVar comRecvBuffer
let
Just routedIn = decode $ LBS.pack encodedRoutedIn :: Maybe RoutedMessageIn
case routedIn of
(InUserCanvas canvasIn) -> do
ins <- takeMVar userRecvBuffer
putMVar userRecvBuffer (ins ++ [canvasIn])
nextStep
(InSystemCanvas canvasIn) -> do
putMVar sysRecvBuffer canvasIn
nextStep
where
nextStep = router comRecvBuffer userRecvBuffer sysRecvBuffer
--TODO
measureText :: IOState -> CanvasId -> CanvasText -> IO ScreenDimensions
measureText canvasState canvasId canvasText = return (4,4)