{-|
Module : EventLoop.Output.Single
Description : Makeshift server to output a single 'EventLoop.Output.OutputEvent' to the client.
Copyright : (c) Sebastiaan la Fleur, 2014
License : BSD3
Maintainer : sebastiaan.la.fleur@gmail.com
Stability : experimental
Portability : All
Makeshift server to output a single 'EventLoop.Output.OutputEvent' to the client. The function 'outSingle' is the heart of this module.
-}
module EventLoop.Output.Single (outSingle) where
import qualified Network.Socket as S
import qualified Network.WebSockets as WS
import qualified Data.Text as T
import Control.Exception (catch, SomeException, throw)
import EventLoop.EventProcessor (IOMessage)
import EventLoop.Output.OutputEvent
import EventLoop.Output.Graphical
import EventLoop.Output.SystemMessage
import EventLoop.Config
import EventLoop.Json
import EventLoop.CommonTypes
{-|
Outputs a single 'EventLoop.Output.OutputEvent'. Right now only 'EventLoop.Output.Draw' events are implemented.
The server automatically determines the maximum 'EventLoop.CommonTypes.Dimension's of the picture and sends a 'EventLoop.Output.Setup' containing those 'EventLoop.CommonTypes.Dimension's.
-}
outSingle :: OutputEvent -> IO ()
outSingle out = S.withSocketsDo $ do
sock <- WS.makeSocket ipadres (fromIntegral port)
pendingConn <- WS.makePendingConnection sock
conn <- WS.acceptRequest pendingConn
let
close = catched sock conn
func = do
sendResponse conn setup
sendResponse conn out'
sendResponse conn closeMsg
WS.sendClose conn (T.pack "")
WS.closeSocket sock
catch func close
where
setup = toIOMessage (setupMessage out)
out' = toIOMessage out
closeMsg = toIOMessage closeMessage
-- | Private
catched :: S.Socket -> WS.Connection -> SomeException -> IO ()
catched sock conn e = do
WS.sendClose conn (T.pack "")
WS.closeSocket sock
throw e
-- | Private
setupMessage :: OutputEvent -> OutputEvent
setupMessage (OutGraphical (Draw g _)) = OutSysMessage [CanvasSetup dim]
where
dim = maxDimensions g
setupMessage _ = OutSysMessage [CanvasSetup (512, 512)]
-- | Private
closeMessage :: OutputEvent
closeMessage = OutSysMessage [Close]
-- | Private
toIOMessage :: OutputEvent -> IOMessage
toIOMessage = toJsonMessage
-- | Private
sendResponse :: WS.Connection -> IOMessage -> IO ()
sendResponse conn response = do
let
string = show response
text = T.pack string
WS.sendTextData conn text
-- | Private
maxDimensions :: GObject -> Dimension
maxDimensions (GObject _ prim []) = maxDimensionsPrim prim
maxDimensions (GObject n prim (c:cs)) = (max w w', max h h')
where
(w, h) = maxDimensions c
(w', h') = maxDimensions (GObject n prim cs)
maxDimensions (Container []) = (0, 0)
maxDimensions (Container (c:cs)) = (max w w', max h h')
where
(w, h) = maxDimensions c
(w', h') = maxDimensions (Container cs)
-- | Private
maxDimensionsPrim :: Primitive -> Dimension
maxDimensionsPrim (Text _ _ _ (x, y) size _ str fromCenter) | fromCenter = (x + (fromIntegral $ length str * 10) / 2, y + size / 2)
| otherwise = (x + (fromIntegral $ length str * 10), y + size)
maxDimensionsPrim (Line _ _ []) = (0, 0)
maxDimensionsPrim (Line _ _ [(x, y)]) = (x, y)
maxDimensionsPrim (Line ec et ((x, y):xs)) = (max x x', max y y')
where
(x', y') = maxDimensionsPrim (Line ec et xs)
maxDimensionsPrim (Rect _ _ _ (x, y) (w, h)) = (x + w / 2, y + h / 2)
maxDimensionsPrim (Arc _ _ _ (x, y) r _ _) = (x + r, y + r)