Mouse.hs

{-# LANGUAGE OverloadedStrings #-}
module Eventloop.Module.Websocket.Mouse.Mouse
    ( setupMouseModuleConfiguration
    , mouseModuleIdentifier
    , mouseInitializer
    , mouseEventRetriever
    , mouseTeardown
    ) where

import Control.Applicative
import Control.Monad
import Control.Concurrent.SafePrint
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Maybe

import Eventloop.Module.Websocket.Mouse.Types
import Eventloop.Types.Common
import Eventloop.Types.Events
import Eventloop.Types.System
import qualified Eventloop.Utility.BufferedWebsockets as WS
import Eventloop.Utility.Config
import Eventloop.Utility.Vectors

setupMouseModuleConfiguration :: EventloopSetupModuleConfiguration
setupMouseModuleConfiguration = ( EventloopSetupModuleConfiguration 
                                    mouseModuleIdentifier
                                    (Just mouseInitializer)
                                    (Just mouseEventRetriever)
                                    Nothing
                                    Nothing
                                    Nothing
                                    (Just mouseTeardown)
                                  )
     

mouseModuleIdentifier :: EventloopModuleIdentifier
mouseModuleIdentifier = "mouse"


instance FromJSON MouseIn where
    parseJSON vO@(Object v)
        = do
            mouseEvent <- parseJSON vO :: Parser MouseEvent
            mouseType  <- parseJSON vO :: Parser MouseType
            point      <- parseJSON vO :: Parser Point
            id         <- v .: "id"    :: Parser NumericId
            return $ Mouse mouseType id mouseEvent point
    
    
instance FromJSON MouseType where
    parseJSON (Object v)
        = do
            type' <- v .: "elementType" :: Parser String
            return $ case type' of "canvas" -> MouseCanvas
                                   "svg"    -> MouseSVG
    
instance FromJSON MouseEvent where
    parseJSON (Object v)
        =   do
                eventType <- v .: "mouseEventType" :: Parser String
                button <- parseJSON (Object v) :: Parser MouseButton
                return $ case eventType of "click"      -> Click button
                                           "dblclick"   -> DoubleClick button
                                           "mousedown"  -> MouseDown button
                                           "mouseup"    -> MouseUp button
                                           "mouseenter" -> MouseEnter
                                           "mouseleave" -> MouseLeave
                                           "mousemove"  -> MouseMove
   
instance FromJSON MouseButton where
    parseJSON (Object v)
        = do
            button <- v .: "button" :: Parser String
            return $ case button of "left"   -> MouseLeft
                                    "middle" -> MouseMiddle
                                    "right"  -> MouseRight

instance FromJSON Point where
    parseJSON (Object v)
        = do
            x <- v .: "x"
            y <- v .: "y"
            return $ Point (x, y)
    
    
mouseInitializer :: Initializer
mouseInitializer sharedIO
    = do
        (recvBuffer, clientSocket, clientConn, serverSock, bufferedReaderThread) <- WS.setupWebsocketConnection ipAddress  mousePort
        safePrintLn (safePrintToken sharedIO) "Mouse connection succesfull"
        return (sharedIO, MouseState recvBuffer clientSocket clientConn serverSock bufferedReaderThread)


mouseEventRetriever :: EventRetriever
mouseEventRetriever sharedIO mouseState = do
                                            messages <- WS.takeMessages (receiveBuffer mouseState)
                                            return (sharedIO, mouseState, map ((.) InMouse messageToMouseIn) messages)

                                    
messageToMouseIn :: WS.Message -> MouseIn
messageToMouseIn message = fromJust.decode $ BL.pack message


mouseTeardown :: Teardown
mouseTeardown sharedIO ms
    = do
        WS.closeWebsocketConnection (serverSocket ms) (clientSocket ms) (clientConnection ms) (bufferedReaderThread ms)
        return sharedIO