Canvas.hs

module Eventloop.Module.Websocket.Canvas.Canvas
    ( setupCanvasModuleConfiguration
    , canvasModuleIdentifier
    , canvasInitializer
    , canvasEventRetriever
    , canvasEventSender
    ) where


import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.SafePrint
import Control.Concurrent.Thread
import Data.Aeson
import Data.Maybe
import qualified Data.ByteString.Lazy.Char8 as LBS

import Eventloop.Module.Websocket.Canvas.Types
import Eventloop.Module.Websocket.Canvas.JSONEncoding
import Eventloop.Types.Common
import Eventloop.Types.Events
import Eventloop.Types.System
import Eventloop.Utility.Config
import Eventloop.Utility.Websockets


setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration
setupCanvasModuleConfiguration = ( EventloopSetupModuleConfiguration
                                        canvasModuleIdentifier
                                        (Just canvasInitializer)
                                        (Just canvasEventRetriever)
                                        Nothing
                                        Nothing
                                        (Just canvasEventSender)
                                        (Just canvasTeardown)
                                      )


canvasModuleIdentifier :: EventloopModuleIdentifier
canvasModuleIdentifier = "canvas"


canvasInitializer :: Initializer
canvasInitializer sharedConst sharedIO
    = do
        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY canvasPort
        safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!"
        sysRecvBuffer <- newEmptyMVar
        measureTextLock <- newMVar ()
        let
            ioConst = CanvasConstants sysRecvBuffer clientSocket clientConn serverSock
            measureText_' = measureText_ ioConst measureTextLock
            sharedConst' = sharedConst{measureText = measureText_'}
        return (sharedConst', sharedIO, ioConst, NoState)


canvasEventRetriever :: EventRetriever
canvasEventRetriever sharedConst sharedIOT ioConst ioStateT
    = do
        isConnected <- isConnected sock
        case isConnected of
            False -> return []
            True -> do
                messageM <- takeMessage safePrintToken_ sock conn
                case messageM of
                    Nothing -> return []
                    (Just message) -> do
                                        let
                                            inRouted = fromJust.decode $ LBS.pack message
                                        inCanvasM <- route sysBuffer inRouted
                                        case inCanvasM of
                                            Nothing         -> return []
                                            (Just inCanvas) -> return [InCanvas inCanvas]
    where
        sock = clientSocket ioConst
        conn = clientConnection ioConst
        sysBuffer = canvasSystemReceiveBuffer ioConst
        safePrintToken_ = safePrintToken sharedConst


canvasEventSender :: EventSender
canvasEventSender sharedConst sharedIOT ioConst ioStateT (OutCanvas canvasOut)
    = sendRoutedMessageOut conn (OutUserCanvas canvasOut)
    where
        conn = clientConnection ioConst

canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop
    = do
        closeWebsocketConnection safePrintToken_ serverSock clientSock conn
    where
        serverSock = serverSocket ioConst
        clientSock = clientSocket ioConst
        conn = clientConnection ioConst
        safePrintToken_ = safePrintToken sharedConst


canvasTeardown :: Teardown
canvasTeardown sharedConst sharedIO ioConst ioState
    = do
        destroyWebsocketConnection serverSock clientSock
        return sharedIO
    where
        serverSock = serverSocket ioConst
        clientSock = clientSocket ioConst
        conn = clientConnection ioConst


sendRoutedMessageOut :: Connection -> RoutedMessageOut -> IO ()
sendRoutedMessageOut conn out = writeMessage conn $ LBS.unpack $ encode out


route :: CanvasSystemReceiveBuffer -> RoutedMessageIn -> IO (Maybe CanvasIn)
route sysRecvBuffer routedIn
    = case routedIn of
        (InUserCanvas canvasIn)   -> return (Just canvasIn)
        (InSystemCanvas canvasIn) -> do
                                        putMVar sysRecvBuffer canvasIn
                                        return Nothing


measureText_ :: IOConstants -> MVar () -> CanvasText -> IO ScreenDimensions
measureText_ ioConst lock canvasText
    = do
        lock_ <- takeMVar lock
        sendRoutedMessageOut conn outMsg
        (SystemMeasuredText _ screenDims) <- takeMVar buf
        putMVar lock lock_
        return screenDims
    where
        conn = clientConnection ioConst
        buf = canvasSystemReceiveBuffer ioConst
        outMsg = OutSystemCanvas $ SystemMeasureText canvasText