diff --git a/eventloop.cabal b/eventloop.cabal --- a/eventloop.cabal +++ b/eventloop.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.5.1.0 +version: 0.6.0.0 synopsis: A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together. description: A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together. Each module exists of a initialize and teardown function that are both called once at startup and shutting down. During run-time, a module can provice a preprocessor function (which transforms input events before they get to the eventloop), @@ -90,12 +90,10 @@ Eventloop.System.SenderThread, Eventloop.System.Setup, Eventloop.System.TeardownThread, - Eventloop.System.ThreadActions, Eventloop.Types.Exception, Eventloop.Utility.Websockets, - Eventloop.Utility.BufferedWebsockets, Eventloop.Utility.Config, Eventloop.Utility.Trees.LayoutTree @@ -109,7 +107,8 @@ suspend >=0.2 && <0.3, aeson >=0.8 && <0.9, bytestring >=0.10 && <0.11, - concurrent-utilities >=0.1 && <0.2 + concurrent-utilities >=0.2 && <0.3, + stm >=2.4 && <2.5 -- Directories containing source files. hs-source-dirs: src diff --git a/src/Eventloop/Core.hs b/src/Eventloop/Core.hs --- a/src/Eventloop/Core.hs +++ b/src/Eventloop/Core.hs @@ -1,6 +1,7 @@ module Eventloop.Core where import Control.Exception +import Control.Concurrent import Control.Concurrent.MVar import Control.Concurrent.ExceptionCollection import Control.Concurrent.Suspend.Lifted @@ -37,52 +38,66 @@ -> IO () startEventloopSystem setupConfig = do - systemconfig <- setupEventloopSystemConfig setupConfig -- Setup - let - moduleConfigs_ = moduleConfigs systemconfig - exceptions_ = exceptions systemconfig - isStoppingM_ = isStoppingM systemconfig - catch ( do - startInitializing systemconfig -- Initialization - let - retrieverThreadActions = threadActionsBasedOnModule systemconfig startRetrieving retrieverM moduleConfigs_ - outRouterAction = startOutRouting systemconfig - senderThreadActions = threadActionsBasedOnModule systemconfig startSending senderConfigM moduleConfigs_ - -- Spawn worker threads - mapM_ (spawnWorkerThread systemconfig registerRetrieverThread) retrieverThreadActions - spawnWorkerThread systemconfig registerOutRouterThread outRouterAction - mapM_ (spawnWorkerThread systemconfig registerSenderThread) senderThreadActions - startEventlooping systemconfig -- Eventlooping - ) - ( \shutdownException -> do - swapMVar isStoppingM_ True -- If its already true, nothing happens, otherwise notify other threads the system thread is already shutting down - logException exceptions_ shutdownException -- Log the thrown exception + systemConfig <- setupEventloopSystemConfig setupConfig -- Setup + systemConfig' <- catch (startInitializing systemConfig) -- Initialization + (\shutdownException -> do + logException (exceptions systemConfig) shutdownException -- Log the thrown exception + return systemConfig + ) + failed <- hasExceptions (exceptions systemConfig') + case failed of + True -> return () + False -> do + let + moduleConfigs_ = moduleConfigs systemConfig' + exceptions_ = exceptions systemConfig' + isStoppingM_ = isStoppingM systemConfig' + catch ( do + let + retrieverThreadActions = threadActionsBasedOnModule systemConfig' startRetrieving retrieverM moduleConfigs_ + outRouterAction = startOutRouting systemConfig' + senderThreadActions = threadActionsBasedOnModule systemConfig' startSending senderConfigM moduleConfigs_ + -- Spawn worker threads + mapM_ (spawnWorkerThread systemConfig' registerRetrieverThread) retrieverThreadActions + spawnWorkerThread systemConfig' registerOutRouterThread outRouterAction + mapM_ (spawnWorkerThread systemConfig' registerSenderThread) senderThreadActions + startEventlooping systemConfig' -- Eventlooping + ) + ( \shutdownException -> do + swapMVar isStoppingM_ True -- If its already true, nothing happens, otherwise notify other threads the system thread is already shutting down + logException exceptions_ shutdownException -- Log the thrown exception - -- Send a stop to the OutRouter - outRouter <- outRouterThread systemconfig - let - eventloopConfig_ = eventloopConfig systemconfig - outEventQueue_ = outEventQueue eventloopConfig_ - putInBlockingConcurrentQueue outEventQueue_ Stop + -- Send a stop to the OutRouter + outRouter <- outRouterThread systemConfig' + let + eventloopConfig_ = eventloopConfig systemConfig' + outEventQueue_ = outEventQueue eventloopConfig_ + putInBlockingConcurrentQueue outEventQueue_ Stop - -- Stop the retriever threads - retrievers <- retrieverThreads systemconfig - mapM_ throwShutdownExceptionToThread retrievers + -- Wait for the Stop to propagate + threadDelay 100000 - -- Kill the outrouter and senders if need be - senders <- senderThreads systemconfig - senderTimers <- mapM (terminateWithinOrThrowException 1000000 (toException ShuttingDownException)) (outRouter ++ senders) + -- Kill the outrouter and senders if need be + senders <- senderThreads systemConfig' + senderTimers <- mapM (terminateWithinOrThrowException 1000000 (toException ShuttingDownException)) (outRouter ++ senders) - -- Wait for all workers - joinThreads (retrievers ++ outRouter ++ senders) - -- Stop all outrouter and sender kill timers if they are still active - mapM_ stopTimer senderTimers + -- Wait for the outRouter and Sender + joinThreads (outRouter ++ senders) - -- Clean up the system - startTeardowning systemconfig - startDisplayingExceptions systemconfig - ) + -- Stop all outrouter and sender kill timers if they are still active + mapM_ stopTimer senderTimers + -- Stop the retriever threads + retrievers <- retrieverThreads systemConfig' + mapM_ throwShutdownExceptionToThread retrievers + + -- Wait for all retrievers + joinThreads retrievers + ) + -- Clean up the system + startTeardowning systemConfig' + startDisplayingExceptions systemConfig' + terminateWithinOrThrowException :: Int -> SomeException -> Thread @@ -124,17 +139,17 @@ thread <- forkThread $ do catch action ( \exception -> - case exception of - ShuttingDownException -> + case (fromException exception) of + (Just ShuttingDownException) -> return () _ -> do isStopping <- takeMVar isStoppingM_ putMVar isStoppingM_ True case isStopping of True -> do - case exception of - RequestShutdownException -> return () - _ -> logException exceptions_ exception + case (fromException exception) of + (Just RequestShutdownException) -> return () + _ -> logException exceptions_ exception False -> throwTo systemTid exception ) logAction systemconfig thread diff --git a/src/Eventloop/DefaultConfiguration.hs b/src/Eventloop/DefaultConfiguration.hs --- a/src/Eventloop/DefaultConfiguration.hs +++ b/src/Eventloop/DefaultConfiguration.hs @@ -31,9 +31,14 @@ , setupStdOutModuleConfiguration ] ) - -setupSharedIOState :: IO SharedIOState -setupSharedIOState + + +setupSharedIOConstants :: IO SharedIOConstants +setupSharedIOConstants = do safePrintToken <- createSafePrintToken - return (SharedIOState safePrintToken undefined) + return (SharedIOConstants safePrintToken undefined) + +setupSharedIOState :: IO SharedIOState +setupSharedIOState + = return SharedIOState diff --git a/src/Eventloop/Module/BasicShapes/BasicShapes.hs b/src/Eventloop/Module/BasicShapes/BasicShapes.hs --- a/src/Eventloop/Module/BasicShapes/BasicShapes.hs +++ b/src/Eventloop/Module/BasicShapes/BasicShapes.hs @@ -27,9 +27,10 @@ basicShapesPostProcessor :: PostProcessor -basicShapesPostProcessor shared iostate (OutBasicShapes basicShapesOut) - = return (shared, iostate, [OutCanvas canvasOut]) +basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutBasicShapes basicShapesOut) + = return [OutCanvas canvasOut] where canvasOut = toCanvasOut basicShapesOut -basicShapesPostProcessor shared iostate out = return (shared, iostate, [out]) +basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT out + = return [out] diff --git a/src/Eventloop/Module/DrawTrees/DrawTrees.hs b/src/Eventloop/Module/DrawTrees/DrawTrees.hs --- a/src/Eventloop/Module/DrawTrees/DrawTrees.hs +++ b/src/Eventloop/Module/DrawTrees/DrawTrees.hs @@ -32,12 +32,13 @@ drawTreesPostProcessor :: PostProcessor -drawTreesPostProcessor shared iostate (OutDrawTrees (DrawTrees canvasId trees)) - = return (shared, iostate, [OutBasicShapes $ DrawShapes canvasId [shapeTrees]]) +drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutDrawTrees (DrawTrees canvasId trees)) + = return [OutBasicShapes $ DrawShapes canvasId [shapeTrees]] where (shapeTrees, _, _) = showGeneralTreeList trees -drawTreesPostProcessor shared iostate out = return (shared, iostate, [out]) +drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT out + = return [out] maxWidth :: Int diff --git a/src/Eventloop/Module/File/File.hs b/src/Eventloop/Module/File/File.hs --- a/src/Eventloop/Module/File/File.hs +++ b/src/Eventloop/Module/File/File.hs @@ -7,6 +7,8 @@ ) where import Data.Maybe +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.STM import System.IO import Eventloop.Module.File.Types @@ -14,6 +16,7 @@ import Eventloop.Types.Events import Eventloop.Types.System + setupFileModuleConfiguration :: EventloopSetupModuleConfiguration setupFileModuleConfiguration = ( EventloopSetupModuleConfiguration fileModuleIdentifier @@ -30,83 +33,96 @@ fileInitializer :: Initializer -fileInitializer sharedIO - = return (sharedIO, FileState [] []) +fileInitializer sharedConst sharedIO + = do + inQueue <- createBlockingConcurrentQueue + return (sharedConst, sharedIO, FileConstants inQueue, FileState []) fileEventRetriever :: EventRetriever -fileEventRetriever sharedIO fs - = return (sharedIO, fs', newFileInEvents') +fileEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + fileInEvents <- takeAllFromBlockingConcurrentQueue queue + return (map InFile fileInEvents) where - newFileInEvents' = map InFile (newFileInEvents fs) - fs' = fs {newFileInEvents = []} + queue = fileInQueue ioConst fileEventSender :: EventSender -fileEventSender sharedIO fileState (OutFile a) +fileEventSender _ _ _ _ Stop = return () +fileEventSender sharedConst sharedIOT ioConst ioStateT (OutFile out) = do - fileState' <- fileEventSender' fileState a - return (sharedIO, fileState') + (FileState openFiles) <- readTVarIO ioStateT + (openFiles', inEvents) <- fileEventSender' openFiles out + atomically $ writeTVar ioStateT (FileState openFiles') + putAllInBlockingConcurrentQueue inQueue inEvents + where + inQueue = fileInQueue ioConst -fileEventSender' :: IOState -> FileOut -> IO IOState -fileEventSender' fs (OpenFile filepath iomode) = do - handle <- openFile filepath iomode - let - fileOpenedEvent = FileOpened filepath True - opened' = (opened fs) ++ [(filepath, handle, iomode)] - otherInEvents = newFileInEvents fs - fs' = fs {newFileInEvents=(otherInEvents ++ [fileOpenedEvent]), opened=opened'} - return fs' +fileEventSender' :: [OpenFile] -> FileOut -> IO ([OpenFile], [FileIn]) +fileEventSender' openFiles (OpenFile filepath iomode) + = do + handle <- openFile filepath iomode + let + fileOpenedEvent = FileOpened filepath True + openFiles' = openFiles ++ [(filepath, handle, iomode)] + return (openFiles', [fileOpenedEvent]) -fileEventSender' fs (CloseFile filepath) | openfileM == Nothing = return fs - | otherwise = do - hClose handle - return fs' - where - openedFiles = opened fs - openfileM = retrieveOpenedFile openedFiles filepath - (fp, handle, iomode) = fromJust openfileM - openedFiles' = removeOpenedFile openedFiles filepath - closedFileEvent = FileClosed filepath True - fs' = fs {newFileInEvents=(newFileInEvents fs ++ [closedFileEvent]), opened=openedFiles'} +fileEventSender' openFiles (CloseFile filepath) + | openFileM == Nothing = return ([], []) + | otherwise = do + hClose handle + return (openFiles', [closedFileEvent]) + where + openFileM = retrieveOpenedFile openFiles filepath + (fp, handle, iomode) = fromJust openFileM + openFiles' = removeOpenedFile openFiles filepath + closedFileEvent = FileClosed filepath True -fileEventSender' fs (RetrieveContents filepath) = doReadAction filepath fs RetrievedContents retrieveContents -fileEventSender' fs (RetrieveLine filepath) = doReadAction filepath fs RetrievedLine hGetLine -fileEventSender' fs (RetrieveChar filepath) = doReadAction filepath fs RetrievedChar hGetChar -fileEventSender' fs (IfEOF filepath) = getFromFile filepath fs fileIsOpened IsEOF hIsEOF +fileEventSender' openFiles (RetrieveContents filepath) + = doReadAction filepath openFiles RetrievedContents retrieveContents + +fileEventSender' openFiles (RetrieveLine filepath) + = doReadAction filepath openFiles RetrievedLine hGetLine + +fileEventSender' openFiles (RetrieveChar filepath) + = doReadAction filepath openFiles RetrievedChar hGetChar + +fileEventSender' openFiles (IfEOF filepath) + = getFromFile filepath openFiles fileIsOpened IsEOF hIsEOF -fileEventSender' fs (WriteTo filepath contents) | fileIsWriteable (opened fs) filepath = do - hPutStr handle contents - let - fs' = fs {newFileInEvents = (newFileInEvents fs) ++ [WroteTo filepath True]} - return fs' - | otherwise = return fs - where - Just (fp, handle, iomode) = retrieveOpenedFile (opened fs) filepath +fileEventSender' openFiles (WriteTo filepath contents) + | fileIsWriteable openFiles filepath = do + hPutStr handle contents + return (openFiles, [WroteTo filepath True]) + | otherwise = return (openFiles, []) + where + Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath -doReadAction :: FilePath -> IOState -> (FilePath -> a -> FileIn) -> (Handle -> IO a) -> IO IOState -doReadAction filepath fs inEvent readAction = getFromFile filepath fs fileIsReadable inEvent readAction +doReadAction :: FilePath + -> [OpenFile] + -> (FilePath -> a -> FileIn) + -> (Handle -> IO a) + -> IO ([OpenFile], [FileIn]) +doReadAction filepath openFiles inEvent readAction + = getFromFile filepath openFiles fileIsReadable inEvent readAction getFromFile :: FilePath -> - IOState -> + [OpenFile] -> ([OpenFile] -> FilePath -> Bool) -> {- Check if the action should be done -} (FilePath -> a -> FileIn) -> {- The inEvent Constructor -} (Handle -> IO a) -> {- The action which will grant a result -} - IO IOState -getFromFile filepath fs@(FileState { opened = opened - , newFileInEvents = newFileInEvents - }) fileCheck inEvent action | fileCheck opened filepath = do - result <- action handle - let - newInEvent = inEvent filepath result - fs' = fs {newFileInEvents=newFileInEvents ++ [newInEvent]} - return fs' - | otherwise = return fs - where - Just (fp, handle, iomode) = retrieveOpenedFile opened filepath + IO ([OpenFile], [FileIn]) +getFromFile filepath openFiles fileCheck inEvent action + | fileCheck openFiles filepath = do + result <- action handle + return (openFiles, [inEvent filepath result]) + | otherwise = return (openFiles, []) + where + Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath fileIsReadable :: [OpenFile] -> FilePath -> Bool @@ -154,11 +170,13 @@ fileTeardown :: Teardown -fileTeardown sharedIO fs = do - closeAllFiles handles - return (sharedIO) - where - handles = map (\(fp, h, iom) -> h) (opened fs) +fileTeardown sharedConst sharedIO ioConst ioState + = do + closeAllFiles handles + return (sharedIO) + where + handles = map (\(fp, h, iom) -> h) (opened ioState) + closeAllFiles :: [Handle] -> IO () closeAllFiles [] = return () diff --git a/src/Eventloop/Module/Graphs/Graphs.hs b/src/Eventloop/Module/Graphs/Graphs.hs --- a/src/Eventloop/Module/Graphs/Graphs.hs +++ b/src/Eventloop/Module/Graphs/Graphs.hs @@ -1,5 +1,6 @@ module Eventloop.Module.Graphs.Graphs where + import Eventloop.Module.Graphs.Types import qualified Eventloop.Module.Websocket.Canvas as C import qualified Eventloop.Module.Websocket.Mouse as M @@ -64,38 +65,38 @@ -- | Abstracts the standardized 'EventLoop.Types.EventTypes' to 'GraphsIn' graphsPreProcessor :: PreProcessor -graphsPreProcessor shared io (InMouse (M.Mouse M.MouseCanvas 1 event (Point p))) - | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return (shared, io, [InGraphs $ Mouse event p]) - | otherwise = return (shared, io, []) +graphsPreProcessor sharedConst sharedIOT ioConst ioStateT (InMouse (M.Mouse M.MouseCanvas 1 event (Point p))) + | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return [InGraphs $ Mouse event p] + | otherwise = return [] where (x, y) = p -graphsPreProcessor shared io k@(InKeyboard (K.Key key)) - = return (shared, io, [k, InGraphs $ Key key]) +graphsPreProcessor sharedConst sharedIOT ioConst ioStateT k@(InKeyboard (K.Key key)) + = return [k, InGraphs $ Key key] -graphsPreProcessor shared io inEvent - = return (shared, io, [inEvent]) +graphsPreProcessor sharedConst sharedIOT ioConst ioStateT inEvent + = return [inEvent] -- | Abstracts 'GraphsOut' back to 'BasicShapes' and 'Canvas' events graphsPostProcessor :: PostProcessor -graphsPostProcessor shared io (OutGraphs SetupGraphs) - = return (shared, io, [ OutCanvas $ C.SetupCanvas canvasIdGraphs 1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) - , OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) - ]) +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs SetupGraphs) + = return [ OutCanvas $ C.SetupCanvas canvasIdGraphs 1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) + , OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) + ] -graphsPostProcessor shared io (OutGraphs (DrawGraph graph)) - = return (shared, io, [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas] - , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes - ]) +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (DrawGraph graph)) + = return [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas] + , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes + ] where shapes = graphToShapes graph -graphsPostProcessor shared io (OutGraphs (Instructions is)) - = return (shared, io, [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas] - , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes - ]) +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (Instructions is)) + = return [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas] + , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes + ] where startPLine = Point (0, 0) endPLine = Point (canvasGraphsWidth, 0) @@ -109,8 +110,8 @@ instructionShapes = map (\(line, top) -> textShape line $ Point (0.5 * canvasGraphsWidth, top)) isAndHeights shapes = [BS.CompositeShape (lineShape:instructionShapes) (Just (Point (0, instructionsBeginAt))) Nothing] -graphsPostProcessor shared io out - = return (shared, io, [out]) +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT out + = return [out] -- | Translates color datatype to RGBA codes colorToRGBAColor :: Color -> BS.Color diff --git a/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs b/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs --- a/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs +++ b/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs @@ -3,9 +3,11 @@ , statefulGraphicsModuleIdentifier , statefulGraphicsInitializer , statefulGraphicsPostProcessor - , statefulGraphicsTeardown ) where +import Control.Concurrent.STM +import Data.Maybe + import Eventloop.Module.StatefulGraphics.Types import Eventloop.Module.Websocket.Canvas @@ -14,10 +16,6 @@ import Eventloop.Types.Events import Eventloop.Types.System -import Data.Maybe - -import Debug.Trace - setupStatefulGraphicsModuleConfiguration :: EventloopSetupModuleConfiguration setupStatefulGraphicsModuleConfiguration = ( EventloopSetupModuleConfiguration statefulGraphicsModuleIdentifier @@ -26,7 +24,7 @@ Nothing (Just statefulGraphicsPostProcessor) Nothing - (Just statefulGraphicsTeardown) + Nothing ) @@ -35,30 +33,29 @@ statefulGraphicsInitializer :: Initializer -statefulGraphicsInitializer sharedIO - = return (sharedIO, StatefulGraphicsState []) - - -statefulGraphicsTeardown :: Teardown -statefulGraphicsTeardown sharedIO statefulState - = return (sharedIO) +statefulGraphicsInitializer sharedConst sharedIO + = return (sharedConst, sharedIO, NoConstants, StatefulGraphicsState []) statefulGraphicsPostProcessor :: PostProcessor -statefulGraphicsPostProcessor shared (StatefulGraphicsState states) (OutStatefulGraphics canvasId commands) - = return (shared, StatefulGraphicsState states', newScene) - where - (state', newScene) = calculateNewScene canvasId state commands - stateM = findGraphicalState states canvasId - state = case stateM of - Just state_ -> state_ - Nothing -> [] - states' = replaceGraphicalState states canvasId state' +statefulGraphicsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutStatefulGraphics canvasId commands) + = atomically $ do + (StatefulGraphicsState states) <- readTVar ioStateT + let + stateM = findGraphicalState states canvasId + state = case stateM of + Just state_ -> state_ + Nothing -> [] + (state', newScene) = calculateNewScene canvasId state commands + states' = replaceGraphicalState states canvasId state' + writeTVar ioStateT (StatefulGraphicsState states') + return newScene -statefulGraphicsPostProcessor shared iostate out - = return (shared, iostate, [out]) +statefulGraphicsPostProcessor sharedConst sharedIOT ioConst ioStateT out + = return [out] + replaceGraphicalState :: GraphicsStates -> CanvasId -> GraphicsState -> GraphicsStates replaceGraphicalState [] id state = [(id, state)] replaceGraphicalState ((id, state):states) canvasId newState @@ -75,9 +72,9 @@ calculateNewScene :: CanvasId -> GraphicsState -> [StatefulGraphicsOut] -> (GraphicsState, [Out]) calculateNewScene canvasId state outs - = trace "Calculate new scene" (state', [clearCanvas, OutBasicShapes $ DrawShapes canvasId basicShapes]) + = (state', [clearCanvas, OutBasicShapes $ DrawShapes canvasId basicShapes]) where - (state', performed) = trace ("Outs: " ++ (show $ length outs)) foldl foldPerform (state, []) outs + (state', performed) = foldl foldPerform (state, []) outs foldPerform (state_, performed_) statefulOut = (state_', performed_ ++ [performed_']) where (state_', performed_') = performStatefulGraphicsOut state_ statefulOut @@ -89,14 +86,14 @@ performStatefulGraphicsOut :: GraphicsState -> StatefulGraphicsOut -> (GraphicsState, GraphicPerformed) performStatefulGraphicsOut state (Draw statefulGraphic) = case oldStatefulGraphicM of - Just oldStatefulGraphic -> trace ("Modified: " ++ (show $ fst statefulGraphic)) (state', Modified statefulGraphic) - Nothing -> trace ("Drawn: " ++ (show $ fst statefulGraphic)) (state', Drawn statefulGraphic) + Just oldStatefulGraphic -> (state', Modified statefulGraphic) + Nothing -> (state', Drawn statefulGraphic) where (state', oldStatefulGraphicM) = addOrReplaceGraphics state statefulGraphic performStatefulGraphicsOut state (Remove id) = case oldStatefulGraphicM of - Just oldStatefulGraphic -> trace ("Removed: " ++ (show id)) (state', Removed oldStatefulGraphic) - Nothing -> trace ("NoOp: " ++ (show id)) (state , NoOp) + Just oldStatefulGraphic -> (state', Removed oldStatefulGraphic) + Nothing -> (state , NoOp) where (state', oldStatefulGraphicM) = removeGraphics state id @@ -117,7 +114,3 @@ | otherwise = (sg:state', result) where (state', result) = removeGraphics state id' - - - - diff --git a/src/Eventloop/Module/StdIn/StdIn.hs b/src/Eventloop/Module/StdIn/StdIn.hs --- a/src/Eventloop/Module/StdIn/StdIn.hs +++ b/src/Eventloop/Module/StdIn/StdIn.hs @@ -8,6 +8,8 @@ import System.IO import Data.String +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.STM import Eventloop.Module.StdIn.Types import Eventloop.Types.Common @@ -31,40 +33,45 @@ stdInInitializer :: Initializer -stdInInitializer sharedIO - = return (sharedIO, StdInState []) +stdInInitializer sharedConst sharedIO + = do + inQueue <- createBlockingConcurrentQueue + return (sharedConst, sharedIO, StdInConstants inQueue, NoState) stdInEventRetriever :: EventRetriever -stdInEventRetriever sharedIO (StdInState events) - = return (sharedIO, StdInState [], inEvents) +stdInEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + inEvents <- takeAllFromBlockingConcurrentQueue inQueue + return (map InStdIn inEvents) where - inEvents = map InStdIn events + inQueue = stdInInQueue ioConst stdInEventSender :: EventSender -stdInEventSender sharedIO stdInState (OutStdIn a) +stdInEventSender _ _ _ _ Stop = return () +stdInEventSender sharedConst sharedIOT ioConst ioStateT (OutStdIn a) = do - stdInState' <- stdInEventSender' stdInState a - return (sharedIO, stdInState') + inEvents <- stdInEventSender' a + putAllInBlockingConcurrentQueue inQueue inEvents + where + inQueue = stdInInQueue ioConst -stdInEventSender' :: IOState -> StdInOut -> IO IOState -stdInEventSender' stdInState StdInReceiveContents - = doStdInGet stdInState linedGetContents StdInReceivedContents +stdInEventSender' :: StdInOut -> IO [StdInIn] +stdInEventSender' StdInReceiveContents + = doStdInGet linedGetContents StdInReceivedContents where linedGetContents = (getContents >>= (\strContents -> return $ lines strContents)) -stdInEventSender' stdInState StdInReceiveLine = doStdInGet stdInState getLine StdInReceivedLine -stdInEventSender' stdInState StdInReceiveChar = doStdInGet stdInState getChar StdInReceivedChar +stdInEventSender' StdInReceiveLine + = doStdInGet getLine StdInReceivedLine +stdInEventSender' StdInReceiveChar + = doStdInGet getChar StdInReceivedChar -doStdInGet :: IOState -> (IO a) -> (a -> StdInIn) -> IO IOState -doStdInGet stdInState source typeEvent = do - let - events = newStdInInEvents stdInState - content <- source - let - event = typeEvent content - events' = events ++ [event] - return (stdInState {newStdInInEvents = events'}) +doStdInGet :: (IO a) -> (a -> StdInIn) -> IO [StdInIn] +doStdInGet source typeEvent + = do + content <- source + return ([typeEvent content]) diff --git a/src/Eventloop/Module/StdOut/StdOut.hs b/src/Eventloop/Module/StdOut/StdOut.hs --- a/src/Eventloop/Module/StdOut/StdOut.hs +++ b/src/Eventloop/Module/StdOut/StdOut.hs @@ -6,6 +6,7 @@ import System.IO +import Control.Concurrent.MVar import Control.Concurrent.SafePrint import Eventloop.Module.StdOut.Types @@ -29,7 +30,13 @@ stdOutEventSender :: EventSender -stdOutEventSender sharedIO state (OutStdOut (StdOutMessage str)) = do - safePrint (safePrintToken sharedIO) str - hFlush stdout - return (sharedIO, state) +stdOutEventSender _ _ _ _ Stop = return () +stdOutEventSender sharedConst sharedIOT ioConst ioStateT (OutStdOut (StdOutMessage str)) + = do + safePrint token str + hFlush stdout + where + token = safePrintToken sharedConst + +stdOutEventSender sharedConst sharedIOT ioConst ioStateT Stop + = return () diff --git a/src/Eventloop/Module/Timer/Timer.hs b/src/Eventloop/Module/Timer/Timer.hs --- a/src/Eventloop/Module/Timer/Timer.hs +++ b/src/Eventloop/Module/Timer/Timer.hs @@ -7,8 +7,9 @@ , timerTeardown ) where +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.STM import Control.Concurrent.Timer -import Control.Concurrent.MVar import Control.Concurrent.Suspend.Lifted import Data.Maybe import Data.List @@ -35,85 +36,119 @@ timerInitializer :: Initializer -timerInitializer sharedIO = do - incTickBuff <- newMVar [] - incITickBuff <- newMVar [] - return (sharedIO, TimerState [] [] incITickBuff incTickBuff) +timerInitializer sharedConst sharedIO + = do + inQueue <- createBlockingConcurrentQueue + return (sharedConst, sharedIO, TimerConstants inQueue, TimerState [] []) timerEventRetriever :: EventRetriever -timerEventRetriever sharedIO timerState = do - let - incTickBuff = incomingTickBuffer timerState - incITickBuff = incomingIntervalTickBuffer timerState - incTicks <- swapMVar incTickBuff [] - incITicks <- swapMVar incITickBuff [] - let - tickedTimerIds = map (\(Tick id) -> id) incTicks - startedTimers' <- foldr (\id startedTimersIO -> (startedTimersIO >>= unregisterTimer id)) (return $ startedTimers timerState) tickedTimerIds - return (sharedIO, timerState{startedTimers = startedTimers'}, (map InTimer incTicks) ++ (map InTimer incITicks)) - +timerEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + inTicks <- takeAllFromBlockingConcurrentQueue inQueue + ioState <- readTVarIO ioStateT -- This first read is just a snapshot + let + toStop = map (\(Tick id) -> id) inTicks + startedTimers_ = startedTimers ioState + sequence $ map (haltTimer startedTimers_) toStop + atomically $ do + ioState' <- readTVar ioStateT + let + startedTimers_' = startedTimers ioState' + startedTimers_'' = foldl unregisterTimer startedTimers_' toStop + writeTVar ioStateT (ioState'{startedTimers = startedTimers_'}) + return (map InTimer inTicks) + where + inQueue = tickInQueue ioConst + + timerEventSender :: EventSender -timerEventSender sharedIO timerState (OutTimer a) = do - timerState' <- timerEventSender' timerState a - return (sharedIO, timerState') +timerEventSender _ _ _ _ Stop = return () +timerEventSender sharedConst sharedIOT ioConst ioStateT (OutTimer a) + = timerEventSender' ioStateT tickBuffer a + where + tickBuffer = tickInQueue ioConst + -timerEventSender' :: IOState -> TimerOut -> IO IOState -timerEventSender' timerState (SetTimer id delay) = do - let - incTickBuff = incomingTickBuffer timerState - startedTimers_ = startedTimers timerState - startedTimers' <- registerTimer startedTimers_ incTickBuff id delay (oneShotStart) - let - timerState' = timerState {startedTimers = startedTimers'} - return timerState' +timerEventSender' :: TVar IOState -> TickBuffer -> TimerOut -> IO () +timerEventSender' ioStateT tickBuffer (SetTimer id delay) + = do + startedTimer <- startTimer tickBuffer id delay (oneShotStart) + atomically $ do + ioState <- readTVar ioStateT + let + startedTimers_' = registerTimer (startedTimers ioState) startedTimer + writeTVar ioStateT ioState{startedTimers=startedTimers_'} -timerEventSender' timerState (SetIntervalTimer id delay) = do - let - incITickBuff = incomingIntervalTickBuffer timerState - startedITimers = startedIntervalTimers timerState - startedITimers' <- registerTimer startedITimers incITickBuff id delay (repeatedStart) - let - timerState' = timerState {startedIntervalTimers = startedITimers'} - return timerState' - -timerEventSender' timerState (UnsetTimer id) = do - startedTimers' <- unregisterTimer id (startedTimers timerState) - startedITimers' <- unregisterTimer id (startedIntervalTimers timerState) - return (timerState {startedTimers = startedTimers', startedIntervalTimers=startedITimers'}) - +timerEventSender' ioStateT tickBuffer (SetIntervalTimer id delay) + = do + startedTimer <- startTimer tickBuffer id delay (repeatedStart) + atomically $ do + ioState <- readTVar ioStateT + let + startedITimers_' = registerTimer (startedIntervalTimers ioState) startedTimer + writeTVar ioStateT ioState{startedIntervalTimers=startedITimers_'} + +timerEventSender' ioStateT tickBuffer (UnsetTimer id) + = do + ioState <- readTVarIO ioStateT -- This first read is just a snapshot + let + startedTimers_ = startedTimers ioState + startedITimers_ = startedIntervalTimers ioState + haltTimer startedTimers_ id + haltTimer startedITimers_ id + atomically $ do + ioState' <- readTVar ioStateT + let + startedTimers_' = startedTimers ioState' + startedITimers_' = startedIntervalTimers ioState' + writeTVar ioStateT ioState'{ startedTimers = startedTimers_' + , startedIntervalTimers = startedITimers_' + } + timerTeardown :: Teardown -timerTeardown sharedIO timerState = do - let - allStartedTimers = (startedTimers timerState) ++ (startedIntervalTimers timerState) - allStartedIds = map fst allStartedTimers - sequence_ (map (\id -> unregisterTimer id allStartedTimers) allStartedIds) - return (sharedIO) +timerTeardown sharedConst sharedIO ioConst ioState + = do + let + allStartedTimers = (startedTimers ioState) ++ (startedIntervalTimers ioState) + allStartedIds = map fst allStartedTimers + sequence_ $ map (haltTimer allStartedTimers) allStartedIds + return sharedIO -registerTimer :: [StartedTimer] -> IncomingTickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO [StartedTimer] -registerTimer startedTimers incTickBuff id delay startFunc = do - timer <- newTimer - startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay) - return (startedTimers ++ [(id, timer)]) - +registerTimer :: [StartedTimer] -> StartedTimer -> [StartedTimer] +registerTimer startedTimers startedTimer + = startedTimers ++ [startedTimer] -unregisterTimer :: TimerId -> [StartedTimer] -> IO [StartedTimer] -unregisterTimer id startedTimers = do - let - startedTimerM = findStartedTimer startedTimers id - stopAction (Just (_, timer)) = stopTimer timer - stopAction Nothing = return () - startedTimers' = filter (\(id', _) -> id /= id') startedTimers - stopAction startedTimerM - return startedTimers' - +startTimer :: TickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO StartedTimer +startTimer incTickBuff id delay startFunc + = do + timer <- newTimer + startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay) + return (id, timer) + + +unregisterTimer :: [StartedTimer] -> TimerId -> [StartedTimer] +unregisterTimer startedTimers id + = filter (\(id', _) -> id /= id') startedTimers + + +haltTimer :: [StartedTimer] -> TimerId -> IO () +haltTimer startedTimers id + = do + let + startedTimerM = findStartedTimer startedTimers id + stopAction (Just (_, timer)) = stopTimer timer + stopAction Nothing = return () + stopAction startedTimerM + + findStartedTimer :: [StartedTimer] -> TimerId -> Maybe StartedTimer findStartedTimer startedTimers id = find (\(id', timer) -> id == id') startedTimers -tick :: TimerId -> IncomingTickBuffer -> IO () -tick id incTickBuff = modifyMVar_ incTickBuff (\ticks -> return $ ticks ++ [Tick id]) +tick :: TimerId -> TickBuffer -> IO () +tick id tickBuffer = putInBlockingConcurrentQueue tickBuffer (Tick id) diff --git a/src/Eventloop/Module/Timer/Types.hs b/src/Eventloop/Module/Timer/Types.hs --- a/src/Eventloop/Module/Timer/Types.hs +++ b/src/Eventloop/Module/Timer/Types.hs @@ -1,12 +1,12 @@ module Eventloop.Module.Timer.Types where -import Control.Concurrent.MVar +import Control.Concurrent.Datastructures.BlockingConcurrentQueue import Control.Concurrent.Timer import Control.Concurrent.Suspend.Lifted type MicroSecondDelay = Int -- Microseconds type TimerId = [Char] -type IncomingTickBuffer = MVar [TimerIn] +type TickBuffer = BlockingConcurrentQueue TimerIn type StartedTimer = (TimerId, TimerIO) type TimerStartFunction = (TimerIO -> IO () -> Delay -> IO Bool) diff --git a/src/Eventloop/Module/Websocket/Canvas/Canvas.hs b/src/Eventloop/Module/Websocket/Canvas/Canvas.hs --- a/src/Eventloop/Module/Websocket/Canvas/Canvas.hs +++ b/src/Eventloop/Module/Websocket/Canvas/Canvas.hs @@ -4,14 +4,15 @@ , canvasInitializer , canvasEventRetriever , canvasEventSender - , canvasTeardown ) 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 @@ -20,7 +21,7 @@ import Eventloop.Types.Events import Eventloop.Types.System import Eventloop.Utility.Config -import qualified Eventloop.Utility.Websockets as WS +import Eventloop.Utility.Websockets setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration @@ -40,73 +41,84 @@ canvasInitializer :: Initializer -canvasInitializer sharedIO +canvasInitializer sharedConst sharedIO = do - (comRecvBuffer, clientSocket, clientConn, serverSock, unbufferedReaderThread) <- WS.setupWebsocketConnection ipAddress canvasPort - putStrLn "Canvas connection successfull!" - userRecvBuffer <- newMVar [] + (clientSocket, clientConn, serverSock) <- setupWebsocketConnection ipAddress canvasPort + safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!" sysRecvBuffer <- newEmptyMVar - routerThread <- forkThread (router comRecvBuffer userRecvBuffer sysRecvBuffer) --TODO Add measuretext to sharedIO - return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientSocket clientConn serverSock unbufferedReaderThread routerThread) - + return (sharedConst, sharedIO, CanvasConstants sysRecvBuffer clientSocket clientConn serverSock, NoState) +{- +TODO: +- Path bug +RELEASE +- measuretext in sharedIO +-} canvasEventRetriever :: EventRetriever -canvasEventRetriever sharedIO canvasState = do - let - userRecvBuffer = canvasUserReceiveBuffer canvasState - messages <- takeMVar userRecvBuffer - putMVar userRecvBuffer [] - return (sharedIO, canvasState, (map InCanvas messages)) +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 sharedIO canvasState (OutCanvas canvasOut) = do - let - conn = clientConnection canvasState - sendRoutedMessageOut conn (OutUserCanvas canvasOut) - return (sharedIO, canvasState) - +canvasEventSender sharedConst sharedIOT ioConst ioStateT (OutCanvas canvasOut) + = sendRoutedMessageOut conn (OutUserCanvas canvasOut) + where + conn = clientConnection ioConst - -canvasTeardown :: Teardown -canvasTeardown sharedIO canvasState +canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop = do - WS.closeWebsocketConnection (serverSocket canvasState) (clientSocket canvasState) (clientConnection canvasState) (unbufferedReaderThread canvasState) - terminateThread (routerThread canvasState) - joinThread (routerThread canvasState) + closeWebsocketConnection safePrintToken_ serverSock clientSock conn -- Todo teardown measureText websocket connection + 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 - - -sendRoutedMessageOut :: WS.Connection -> RoutedMessageOut -> IO () -sendRoutedMessageOut conn out = WS.writeMessage conn $ LBS.unpack $ encode out + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst -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 +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 + --TODO measureText :: IOState -> CanvasId -> CanvasText -> IO ScreenDimensions measureText canvasState canvasId canvasText = return (4,4) - - - - - - - diff --git a/src/Eventloop/Module/Websocket/Canvas/Types.hs b/src/Eventloop/Module/Websocket/Canvas/Types.hs --- a/src/Eventloop/Module/Websocket/Canvas/Types.hs +++ b/src/Eventloop/Module/Websocket/Canvas/Types.hs @@ -4,8 +4,11 @@ import Eventloop.Types.Common -type CanvasUserReceiveBuffer = MVar [CanvasIn] type CanvasSystemReceiveBuffer = MVar SystemCanvasIn + +instance Show (MVar a) where + show _ = "CanvasSystemReceiveBuffer" + type Opcode = Int diff --git a/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs b/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs --- a/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs +++ b/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs @@ -4,12 +4,13 @@ , keyboardModuleIdentifier , keyboardInitializer , keyboardEventRetriever - , keyboardTeardown + , keyboardEventSender ) where import Data.Aeson import Data.Maybe import Control.Applicative +import Control.Concurrent.MVar import Control.Concurrent.SafePrint import qualified Data.ByteString.Lazy.Char8 as BL @@ -18,7 +19,7 @@ import Eventloop.Types.System import Eventloop.Module.Websocket.Keyboard.Types import Eventloop.Utility.Config -import qualified Eventloop.Utility.BufferedWebsockets as WS +import Eventloop.Utility.Websockets setupKeyboardModuleConfiguration :: EventloopSetupModuleConfiguration @@ -28,8 +29,8 @@ (Just keyboardEventRetriever) Nothing Nothing + (Just keyboardEventSender) Nothing - (Just keyboardTeardown) ) @@ -42,29 +43,50 @@ keyboardInitializer :: Initializer -keyboardInitializer sharedIO +keyboardInitializer sharedConst sharedIO = do - (recvBuffer, clientSocket, clientConn, serverSock, bufferedReaderThread) <- WS.setupWebsocketConnection ipAddress keyboardPort - safePrintLn (safePrintToken sharedIO) "Keyboard connection successfull" - return (sharedIO, KeyboardState recvBuffer clientSocket clientConn serverSock bufferedReaderThread) + (clientSocket, clientConn, serverSock) <- setupWebsocketConnection ipAddress keyboardPort + safePrintLn (safePrintToken sharedConst) "Keyboard connection successfull" + return (sharedConst, sharedIO, KeyboardConstants clientSocket clientConn serverSock, NoState) keyboardEventRetriever :: EventRetriever -keyboardEventRetriever sharedIO keyboardState = do - messages <- WS.takeMessages (receiveBuffer keyboardState) - return (sharedIO, keyboardState, map ((.) InKeyboard messageToKeyboardIn) messages) - +keyboardEventRetriever 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) -> return [InKeyboard $ messageToKeyboardIn message] + where + sock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst -messageToKeyboardIn :: WS.Message -> Keyboard + +messageToKeyboardIn :: Message -> Keyboard messageToKeyboardIn message = fromJust.decode $ BL.pack message +keyboardEventSender :: EventSender +keyboardEventSender sharedConst sharedIOT ioConst ioStateT Stop + = do + closeWebsocketConnection safePrintToken_ serverSock clientSock conn + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + keyboardTeardown :: Teardown -keyboardTeardown sharedIO ks +keyboardTeardown sharedConst sharedIO ioConst ioState = do - WS.closeWebsocketConnection (serverSocket ks) (clientSocket ks) (clientConnection ks) (bufferedReaderThread ks) + destroyWebsocketConnection serverSock clientSock return sharedIO - - - - + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst diff --git a/src/Eventloop/Module/Websocket/Mouse/Mouse.hs b/src/Eventloop/Module/Websocket/Mouse/Mouse.hs --- a/src/Eventloop/Module/Websocket/Mouse/Mouse.hs +++ b/src/Eventloop/Module/Websocket/Mouse/Mouse.hs @@ -4,11 +4,12 @@ , mouseModuleIdentifier , mouseInitializer , mouseEventRetriever - , mouseTeardown + , mouseEventSender ) where import Control.Applicative import Control.Monad +import Control.Concurrent.MVar import Control.Concurrent.SafePrint import Data.Aeson import Data.Aeson.Types @@ -19,7 +20,7 @@ import Eventloop.Types.Common import Eventloop.Types.Events import Eventloop.Types.System -import qualified Eventloop.Utility.BufferedWebsockets as WS +import Eventloop.Utility.Websockets import Eventloop.Utility.Config import Eventloop.Utility.Vectors @@ -30,8 +31,8 @@ (Just mouseEventRetriever) Nothing Nothing + (Just mouseEventSender) Nothing - (Just mouseTeardown) ) @@ -86,26 +87,51 @@ mouseInitializer :: Initializer -mouseInitializer sharedIO +mouseInitializer sharedConst 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) + (clientSocket, clientConn, serverSock) <- setupWebsocketConnection ipAddress mousePort + safePrintLn (safePrintToken sharedConst) "Mouse connection succesfull" + return (sharedConst, sharedIO, MouseConstants clientSocket clientConn serverSock, NoState) mouseEventRetriever :: EventRetriever -mouseEventRetriever sharedIO mouseState = do - messages <- WS.takeMessages (receiveBuffer mouseState) - return (sharedIO, mouseState, map ((.) InMouse messageToMouseIn) messages) +mouseEventRetriever 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) -> return [InMouse $ messageToMouseIn message] + where + sock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst - -messageToMouseIn :: WS.Message -> MouseIn + +messageToMouseIn :: Message -> MouseIn messageToMouseIn message = fromJust.decode $ BL.pack message +mouseEventSender :: EventSender +mouseEventSender sharedConst sharedIOT ioConst ioStateT Stop + = do + closeWebsocketConnection safePrintToken_ serverSock clientSock conn + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + + mouseTeardown :: Teardown -mouseTeardown sharedIO ms +mouseTeardown sharedConst sharedIO ioConst ioState = do - WS.closeWebsocketConnection (serverSocket ms) (clientSocket ms) (clientConnection ms) (bufferedReaderThread ms) + destroyWebsocketConnection serverSock clientSock return sharedIO - + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst diff --git a/src/Eventloop/System/DisplayExceptionThread.hs b/src/Eventloop/System/DisplayExceptionThread.hs --- a/src/Eventloop/System/DisplayExceptionThread.hs +++ b/src/Eventloop/System/DisplayExceptionThread.hs @@ -2,7 +2,9 @@ ( startDisplayingExceptions ) where +import qualified Control.Exception as E import Control.Concurrent.ExceptionCollection +import Control.Concurrent.SafePrint import Eventloop.Types.Exception import Eventloop.Types.System @@ -13,9 +15,12 @@ startDisplayingExceptions systemConfig = do exceptions_ <- collectExceptions (exceptions systemConfig) - mapM_ displayException exceptions_ + mapM_ (displayException safePrintToken_) exceptions_ + where + safePrintToken_ = safePrintToken (sharedIOConstants systemConfig) -displayException :: EventloopException +displayException :: SafePrintToken + -> E.SomeException -> IO () -displayException eventloopException = putStrLn (show eventloopException) +displayException safePrintToken exception = safePrintLn safePrintToken (show exception) diff --git a/src/Eventloop/System/EventloopThread.hs b/src/Eventloop/System/EventloopThread.hs --- a/src/Eventloop/System/EventloopThread.hs +++ b/src/Eventloop/System/EventloopThread.hs @@ -4,6 +4,7 @@ import Control.Monad import Control.Concurrent.ExceptionUtility import Control.Concurrent.MVar +import Control.Concurrent.STM import Control.Concurrent.Datastructures.BlockingConcurrentQueue import Data.Maybe @@ -16,18 +17,25 @@ startEventlooping :: EventloopSystemConfiguration progstateT -> IO () startEventlooping systemConfig - = do - putInBlockingConcurrentQueue inEventQueue_ Start - forever $ do - inEvent <- takeFromBlockingConcurrentQueue inEventQueue_ -- Take an In event - processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it - outEvents <- eventloopSteps eventloop progstateM_ processedInEvents -- Eventloop over the preprocessed In events - processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events - putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter + = handle + ( \exception -> + case (fromException exception) of + (Just RequestShutdownException) -> throwIO RequestShutdownException + _ -> throwIO (EventloopException exception) + ) + ( do + putInBlockingConcurrentQueue inEventQueue_ Start + forever $ do + inEvent <- takeFromBlockingConcurrentQueue inEventQueue_ -- Take an In event + processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it + outEvents <- eventloopSteps eventloop progstateT_ processedInEvents -- Eventloop over the preprocessed In events + processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events + putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter + ) where eventloopConfig_ = eventloopConfig systemConfig eventloop = eventloopFunc eventloopConfig_ - progstateM_ = progstateM eventloopConfig_ + progstateT_ = progstateT eventloopConfig_ inEventQueue_ = inEventQueue eventloopConfig_ outEventQueue_ = outEventQueue eventloopConfig_ moduleConfigurations_ = moduleConfigs systemConfig @@ -36,44 +44,35 @@ findProcessors :: [EventloopModuleConfiguration] - -> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -- Pre-/Postprocessor function - -> [(EventloopModuleIdentifier, MVar IOState, (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])))] + -> (EventloopModuleConfiguration -> Maybe (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])) -- Pre-/Postprocessor function + -> [(EventloopModuleIdentifier, IOConstants, TVar IOState, (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]))] findProcessors moduleConfigs getProcessorFunc = moduleProcessors where - moduleProcessorsM = map (\moduleConfig -> (moduleId moduleConfig, iostateM moduleConfig, getProcessorFunc moduleConfig)) moduleConfigs - moduleProcessorsJ = filter (\(_, _, processFuncM) -> isJust processFuncM) moduleProcessorsM - moduleProcessors = map (\(id, iostate, (Just processFunc)) -> (id, iostate, processFunc)) moduleProcessorsJ + moduleProcessorsM = map (\moduleConfig -> (moduleId moduleConfig, ioConstants moduleConfig, ioStateT moduleConfig, getProcessorFunc moduleConfig)) moduleConfigs + moduleProcessorsJ = filter (\(_, _, _, processFuncM) -> isJust processFuncM) moduleProcessorsM + moduleProcessors = map (\(id, ioConst, iostate, (Just processFunc)) -> (id, ioConst, iostate, processFunc)) moduleProcessorsJ eventloopSteps :: (progstateT -> In -> (progstateT, [Out])) {-| eventloop function -} - -> MVar progstateT + -> TVar progstateT -> [In] -> IO [Out] -eventloopSteps eventloop progstateM inEvents +eventloopSteps eventloop progstateT inEvents = sequencedSteps >>= (return.concat) where - inEventSteps = map (eventloopStep eventloop progstateM) inEvents + inEventSteps = map (eventloopStep eventloop progstateT) inEvents sequencedSteps = sequence inEventSteps eventloopStep :: (progstateT -> In -> (progstateT, [Out])) {-| eventloop function -} - -> MVar progstateT + -> TVar progstateT -> In -> IO [Out] -eventloopStep eventloop progstateM inEvent - = catch - ( uninterruptibleUpdateResourceAndCalculate - ( takeMVar progstateM - ) - ( \progstate' -> - putMVar progstateM progstate' - ) - ( \progstate -> - return (eventloop progstate inEvent) - ) - ) - ( \exception -> - throwIO (EventloopException exception) - ) - >>= return.snd +eventloopStep eventloop progStateT inEvent + = do + progState <- readTVarIO progStateT + let + (progState', outEvents) = eventloop progState inEvent + atomically $ writeTVar progStateT progState' + return outEvents diff --git a/src/Eventloop/System/InitializationThread.hs b/src/Eventloop/System/InitializationThread.hs --- a/src/Eventloop/System/InitializationThread.hs +++ b/src/Eventloop/System/InitializationThread.hs @@ -3,34 +3,56 @@ ) where import Control.Exception -import Control.Concurrent.MVar +import Control.Concurrent.STM -import Eventloop.System.ThreadActions import Eventloop.Types.Exception import Eventloop.Types.System startInitializing :: EventloopSystemConfiguration progstateT - -> IO () + -> IO (EventloopSystemConfiguration progstateT) startInitializing systemConfig - = mapM_ (initializeModule sharedIOStateM_) moduleConfigs_ + = do + sharedIO <- readTVarIO sharedIOT_ + (sharedConst', sharedIO', moduleConfigs_') <- initializeModules sharedConst sharedIO moduleConfigs_ + atomically $ writeTVar sharedIOT_ sharedIO' + return systemConfig{moduleConfigs = moduleConfigs_', sharedIOConstants = sharedConst'} where - sharedIOStateM_ = sharedIOStateM systemConfig + sharedConst = sharedIOConstants systemConfig + sharedIOT_ = sharedIOStateT systemConfig moduleConfigs_ = moduleConfigs systemConfig - -initializeModule :: MVar SharedIOState + +initializeModules :: SharedIOConstants + -> SharedIOState + -> [EventloopModuleConfiguration] + -> IO (SharedIOConstants, SharedIOState, [EventloopModuleConfiguration]) +initializeModules sharedConst sharedIO [] = return (sharedConst, sharedIO, []) +initializeModules sharedConst sharedIO (moduleConfig:configs) + = do + (sharedConst', sharedIO', moduleConfig') <- initializeModule sharedConst sharedIO moduleConfig + (sharedConst'', sharedIO'', configs') <- initializeModules sharedConst' sharedIO' configs + return (sharedConst'', sharedIO'', moduleConfig':configs') + + +initializeModule :: SharedIOConstants + -> SharedIOState -> EventloopModuleConfiguration - -> IO () -initializeModule sharedIOStateM_ moduleConfig + -> IO (SharedIOConstants, SharedIOState, EventloopModuleConfiguration) +initializeModule sharedConst sharedIO moduleConfig = case (initializerM moduleConfig) of - Nothing -> return () - (Just initializer) -> do - initializeIOState sharedIOStateM_ iostateM_ - ( \exception -> - throwIO (InitializationException moduleId_ exception) - ) - initializer + Nothing -> return (sharedConst, sharedIO, moduleConfig) + (Just initializer) -> handle + ( \exception -> + throwIO (InitializationException moduleId_ exception) + ) + ( do + ioState <- readTVarIO ioStateT_ + (sharedConst', sharedIO', ioConst', ioState') <- initializer sharedConst sharedIO + atomically $ writeTVar ioStateT_ ioState' + return (sharedConst', sharedIO', moduleConfig {ioConstants = ioConst'}) + ) where moduleId_ = moduleId moduleConfig - iostateM_ = iostateM moduleConfig + ioConst = ioConstants moduleConfig + ioStateT_ = ioStateT moduleConfig diff --git a/src/Eventloop/System/Processing.hs b/src/Eventloop/System/Processing.hs --- a/src/Eventloop/System/Processing.hs +++ b/src/Eventloop/System/Processing.hs @@ -2,7 +2,7 @@ import Control.Exception import Control.Concurrent.ExceptionUtility -import Control.Concurrent.MVar +import Control.Concurrent.STM import Eventloop.Types.Common import Eventloop.Types.Exception @@ -11,70 +11,63 @@ {- To handle the pre-/postprocessing of in/out events - Per module is needed: (moduleIdentifier, iostateM, processFunc) + Per module is needed: (moduleIdentifier, ioStateT, processFunc) Only modules with the appropriate processFunc are included if they exist -} processEventWithModule :: ProcessingDescription - -> MVar SharedIOState + -> SharedIOConstants + -> TVar SharedIOState -> ( EventloopModuleIdentifier - , MVar IOState - , (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])) + , IOConstants + , TVar IOState + , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) ) -> event -> IO [event] -processEventWithModule processingDescription sharedIOM (moduleId, iostateM, processFunc) event - = catch - ( uninterruptibleUpdateResourceAndCalculate - ( do - sharedIO <- takeMVar sharedIOM - iostate <- takeMVar iostateM - return (sharedIO, iostate) - ) - ( \(sharedIO', iostate') -> do - putMVar sharedIOM sharedIO' - putMVar iostateM iostate' - ) - ( \(sharedIO, iostate) -> do - (sharedIO', iostate', events') <- processFunc sharedIO iostate event - return ((sharedIO', iostate'), events') - ) - ) +processEventWithModule processingDescription sharedConst sharedIOT (moduleId, ioConst, ioStateT, processFunc) event + = handle ( \exception -> throwIO (ProcessingException processingDescription moduleId exception) ) - >>= return.snd + ( do + processFunc sharedConst sharedIOT ioConst ioStateT event + ) processEventsWithModules :: ProcessingDescription - -> MVar SharedIOState + -> SharedIOConstants + -> TVar SharedIOState -> [( EventloopModuleIdentifier - , MVar IOState - , (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])) + , IOConstants + , TVar IOState + , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) )] -> [event] -> IO [event] -processEventsWithModules _ _ _ [] +processEventsWithModules _ _ _ _ [] = return [] -processEventsWithModules _ _ [] events +processEventsWithModules _ _ _ [] events = return events -processEventsWithModules processingDescription sharedIOM (moduleProcessor:mps) (event:events) +processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) (event:events) = do - generatedEvents <- processEventWithModule processingDescription sharedIOM moduleProcessor event - processedEvents <- processEventsWithModules processingDescription sharedIOM mps generatedEvents - restProcessedEvents <- processEventsWithModules processingDescription sharedIOM (moduleProcessor:mps) events + generatedEvents <- processEventWithModule processingDescription sharedConst sharedIOT moduleProcessor event + processedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT mps generatedEvents + restProcessedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) events return (processedEvents ++ restProcessedEvents) processEvents :: ProcessingDescription -> EventloopSystemConfiguration progstateT -> [( EventloopModuleIdentifier - , MVar IOState - , (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])) + , IOConstants + , TVar IOState + , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) )] -> [event] -> IO [event] processEvents processingDescription systemConfig moduleProcessors events - = processEventsWithModules processingDescription sharedIOM moduleProcessors events + = processEventsWithModules processingDescription sharedConst sharedIOT moduleProcessors events where - sharedIOM = sharedIOStateM systemConfig + sharedIOT = sharedIOStateT systemConfig + sharedConst = sharedIOConstants systemConfig diff --git a/src/Eventloop/System/RetrieverThread.hs b/src/Eventloop/System/RetrieverThread.hs --- a/src/Eventloop/System/RetrieverThread.hs +++ b/src/Eventloop/System/RetrieverThread.hs @@ -2,10 +2,9 @@ import Control.Exception import Control.Monad -import Control.Concurrent.MVar +import Control.Concurrent.STM import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Eventloop.System.ThreadActions import Eventloop.Types.Common import Eventloop.Types.Exception import Eventloop.Types.System @@ -14,31 +13,33 @@ -> (EventloopModuleConfiguration, EventRetriever) -> IO () startRetrieving systemConfig (moduleConfig, retriever) - = forever (retrieveOne moduleId_ sharedIOStateM_ iostateM_ retriever inEventQueue_) + = forever (retrieveOne moduleId_ sharedConst sharedIOStateT_ ioConst ioStateT_ retriever inEventQueue_) where moduleId_ = moduleId moduleConfig eventloopConfiguration = eventloopConfig systemConfig - sharedIOStateM_ = sharedIOStateM systemConfig + sharedConst = sharedIOConstants systemConfig + sharedIOStateT_ = sharedIOStateT systemConfig inEventQueue_ = inEventQueue eventloopConfiguration - iostateM_ = iostateM moduleConfig + ioConst = ioConstants moduleConfig + ioStateT_ = ioStateT moduleConfig retrieveOne :: EventloopModuleIdentifier -> - MVar SharedIOState -> - MVar IOState -> + SharedIOConstants -> + TVar SharedIOState -> + IOConstants -> + TVar IOState -> EventRetriever -> InEventQueue -> IO () -retrieveOne moduleId sharedIOStateM_ iostateM retriever inEventQueue - = withSharedIOStateAndIOState sharedIOStateM_ iostateM - ( \exception -> - -- Wrap the exception if it isn't a ShuttingDownException - case (fromException exception) of - (Just ShuttingDownException) -> throwIO ShuttingDownException - _ -> throwIO (RetrievingException moduleId exception) - ) - ( \sharedIOState iostate -> do - (sharedIOState', iostate', inEvents) <- retriever sharedIOState iostate - putAllInBlockingConcurrentQueue inEventQueue inEvents - return (sharedIOState', iostate') - ) +retrieveOne moduleId sharedConst sharedIOT ioConst iostateT retriever inEventQueue + = handle ( \exception -> + -- Wrap the exception if it isn't a ShuttingDownException + case (fromException exception) of + (Just ShuttingDownException) -> throwIO ShuttingDownException + _ -> throwIO (RetrievingException moduleId exception) + ) + ( do + inEvents <- retriever sharedConst sharedIOT ioConst iostateT + putAllInBlockingConcurrentQueue inEventQueue inEvents + ) diff --git a/src/Eventloop/System/SenderThread.hs b/src/Eventloop/System/SenderThread.hs --- a/src/Eventloop/System/SenderThread.hs +++ b/src/Eventloop/System/SenderThread.hs @@ -2,10 +2,9 @@ import Control.Exception import Control.Monad -import Control.Concurrent.MVar +import Control.Concurrent.STM import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Eventloop.System.ThreadActions import Eventloop.Types.Common import Eventloop.Types.Events import Eventloop.Types.Exception @@ -18,30 +17,34 @@ = forever $ do outEvent <- takeFromBlockingConcurrentQueue senderEventQueue_ case outEvent of - Stop -> throwIO RequestShutdownException - _ -> sendOne moduleId_ sharedIOStateM_ iostateM_ sender_ outEvent + Stop -> do + sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ Stop + throwIO RequestShutdownException + _ -> sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ outEvent where moduleId_ = moduleId moduleConfig - sharedIOStateM_ = sharedIOStateM systemConfig - iostateM_ = iostateM moduleConfig + sharedConst = sharedIOConstants systemConfig + sharedIOT = sharedIOStateT systemConfig + ioConst = ioConstants moduleConfig + ioStateT_ = ioStateT moduleConfig sender_ = sender moduleSenderConfig senderEventQueue_ = senderEventQueue moduleSenderConfig sendOne :: EventloopModuleIdentifier - -> MVar SharedIOState - -> MVar IOState + -> SharedIOConstants + -> TVar SharedIOState + -> IOConstants + -> TVar IOState -> EventSender -> Out -> IO () -sendOne moduleId sharedIOStateM_ iostateM sender outEvent - = withSharedIOStateAndIOState sharedIOStateM_ iostateM - ( \exception -> - -- Wrap the exception if it isn't a ShuttingDownException - case (fromException exception) of - (Just ShuttingDownException) -> throwIO ShuttingDownException - _ -> throwIO (SendingException moduleId outEvent exception) - ) - ( \sharedIOState iostate -> - sender sharedIOState iostate outEvent - ) +sendOne moduleId sharedConst sharedIOT ioConst ioStateT sender outEvent + = handle ( \exception -> + -- Wrap the exception if it isn't a ShuttingDownException + case (fromException exception) of + (Just ShuttingDownException) -> throwIO ShuttingDownException + _ -> throwIO (SendingException moduleId outEvent exception) + ) + ( sender sharedConst sharedIOT ioConst ioStateT outEvent + ) diff --git a/src/Eventloop/System/Setup.hs b/src/Eventloop/System/Setup.hs --- a/src/Eventloop/System/Setup.hs +++ b/src/Eventloop/System/Setup.hs @@ -5,6 +5,7 @@ import Control.Concurrent import Control.Concurrent.ExceptionCollection import Control.Concurrent.MVar +import Control.Concurrent.STM import Control.Concurrent.Datastructures.BlockingConcurrentQueue import Eventloop.DefaultConfiguration @@ -17,8 +18,9 @@ = do eventloopConfig_ <- setupEventloopConfiguration setupConfig moduleConfigurations_ <- mapM setupEventloopModuleConfig (setupModuleConfigurations setupConfig) + sharedIOConst <- setupSharedIOConstants sharedIOState_ <- setupSharedIOState - sharedIOStateM_ <- newMVar sharedIOState_ + sharedIOStateT_ <- newTVarIO sharedIOState_ systemThreadId_ <- myThreadId retrieverThreadsM_ <- newMVar [] outRouterThreadM_ <- newEmptyMVar @@ -29,7 +31,8 @@ return ( EventloopSystemConfiguration eventloopConfig_ moduleConfigurations_ - sharedIOStateM_ + sharedIOConst + sharedIOStateT_ systemThreadId_ retrieverThreadsM_ outRouterThreadM_ @@ -43,12 +46,12 @@ -> IO (EventloopConfiguration progstateT) setupEventloopConfiguration setupConfig = do - progstateM_ <- newMVar (beginProgstate setupConfig) + progStateT_ <- newTVarIO (beginProgstate setupConfig) inEventQueue_ <- createBlockingConcurrentQueue outEventQueue_ <- createBlockingConcurrentQueue return ( EventloopConfiguration - progstateM_ + progStateT_ (eventloopF setupConfig) inEventQueue_ outEventQueue_ @@ -59,12 +62,13 @@ -> IO EventloopModuleConfiguration setupEventloopModuleConfig setupModuleConfig = do - iostateM <- newMVar NoState + ioStateT <- newTVarIO NoState senderConfig <- setupEventloopModuleSenderConfiguration (eventSenderF setupModuleConfig) return ( EventloopModuleConfiguration (moduleIdentifier setupModuleConfig) - iostateM + NoConstants + ioStateT (initializerF setupModuleConfig) (eventRetrieverF setupModuleConfig) (preprocessorF setupModuleConfig) diff --git a/src/Eventloop/System/TeardownThread.hs b/src/Eventloop/System/TeardownThread.hs --- a/src/Eventloop/System/TeardownThread.hs +++ b/src/Eventloop/System/TeardownThread.hs @@ -3,9 +3,9 @@ ) where import Control.Exception -import Control.Concurrent.MVar +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.STM -import Eventloop.System.ThreadActions import Eventloop.Types.Exception import Eventloop.Types.System @@ -13,24 +13,46 @@ startTeardowning :: EventloopSystemConfiguration progstateT -> IO () startTeardowning systemConfig - = mapM_ (teardownModule sharedIOStateM_) moduleConfigs_ + = do + sharedIO <- readTVarIO sharedIOStateT_ + sharedIO' <- teardownModules sharedConst sharedIO systemConfig moduleConfigs_ + atomically $ writeTVar sharedIOStateT_ sharedIO' where - sharedIOStateM_ = sharedIOStateM systemConfig + sharedConst = sharedIOConstants systemConfig + sharedIOStateT_ = sharedIOStateT systemConfig moduleConfigs_ = moduleConfigs systemConfig -teardownModule :: MVar SharedIOState - -> EventloopModuleConfiguration - -> IO () -teardownModule sharedIOStateM_ moduleConfig +teardownModules :: SharedIOConstants + -> SharedIOState + -> EventloopSystemConfiguration progstateT + -> [EventloopModuleConfiguration] + -> IO SharedIOState +teardownModules _ sharedIO _ [] = return sharedIO +teardownModules sharedConst sharedIO systemConfig (moduleConfig:configs) + = do + sharedIO' <- teardownModule sharedConst sharedIO systemConfig moduleConfig + teardownModules sharedConst sharedIO' systemConfig configs + + +teardownModule :: SharedIOConstants + -> SharedIOState + -> EventloopSystemConfiguration progstateT + -> EventloopModuleConfiguration + -> IO SharedIOState +teardownModule sharedConst sharedIO systemConfig moduleConfig = case (teardownM moduleConfig) of - Nothing -> return () - (Just teardown) -> - teardownIOState sharedIOStateM_ iostateM_ - ( \exception -> - throwIO (TeardownException moduleId_ exception) + Nothing -> return (sharedIO) + (Just teardown) -> handle + ( \exception -> do + logException (exceptions systemConfig) (toException $ TeardownException moduleId_ exception) + return sharedIO ) - teardown + ( do + ioState <- readTVarIO ioStateT_ + teardown sharedConst sharedIO ioConst ioState + ) where moduleId_ = moduleId moduleConfig - iostateM_ = iostateM moduleConfig + ioConst = ioConstants moduleConfig + ioStateT_ = ioStateT moduleConfig diff --git a/src/Eventloop/System/ThreadActions.hs b/src/Eventloop/System/ThreadActions.hs deleted file mode 100644 --- a/src/Eventloop/System/ThreadActions.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Eventloop.System.ThreadActions where - -import Control.Exception -import Control.Monad -import Control.Concurrent.ExceptionUtility -import Control.Concurrent.MVar - -import Eventloop.Types.System - -withSharedIOStateAndIOState :: MVar SharedIOState - -> MVar IOState - -> (SomeException -> IO ()) - -> (SharedIOState -> IOState -> IO (SharedIOState, IOState)) - -> IO () -withSharedIOStateAndIOState sharedIOStateM_ iostateM_ onException updateFunc - = catch ( - void $ uninterruptibleUpdateResource - ( do - sharedIOState <- takeMVar sharedIOStateM_ - iostate <- takeMVar iostateM_ - return (sharedIOState, iostate) - ) - ( \(sharedIOState', iostate') -> do - putMVar sharedIOStateM_ sharedIOState' - putMVar iostateM_ iostate' - ) - ( \(sharedIOState, iostate) -> - updateFunc sharedIOState iostate - ) - ) - ( \exception -> - onException exception - ) - - -initializeIOState :: MVar SharedIOState - -> MVar IOState - -> (SomeException -> IO ()) - -> (SharedIOState -> IO (SharedIOState, IOState)) - -> IO () -initializeIOState sharedIOStateM_ iostateM_ onException updateFunc - = catch ( - void $ uninterruptibleUpdateResource - ( do - sharedIOState <- takeMVar sharedIOStateM_ - iostate <- takeMVar iostateM_ - return (sharedIOState, iostate) - ) - ( \(sharedIOState', iostate') -> do - putMVar sharedIOStateM_ sharedIOState' - putMVar iostateM_ iostate' - ) - ( \(sharedIOState, iostate) -> - updateFunc sharedIOState - ) - ) - ( \exception -> - onException exception - ) - - -teardownIOState :: MVar SharedIOState - -> MVar IOState - -> (SomeException -> IO ()) - -> (SharedIOState -> IOState -> IO SharedIOState) - -> IO () -teardownIOState sharedIOStateM_ iostateM_ onException updateFunc - = catch ( - void $ uninterruptibleUpdateResource - ( do - sharedIOState <- takeMVar sharedIOStateM_ - iostate <- takeMVar iostateM_ - return (sharedIOState, iostate) - ) - ( \(sharedIOState', _) -> do - putMVar sharedIOStateM_ sharedIOState' - putMVar iostateM_ NoState - ) - ( \(sharedIOState, iostate) -> do - sharedIOState' <- updateFunc sharedIOState iostate - return (sharedIOState', undefined) - ) - ) - ( \exception -> - onException exception - ) diff --git a/src/Eventloop/Types/System.hs b/src/Eventloop/Types/System.hs --- a/src/Eventloop/Types/System.hs +++ b/src/Eventloop/Types/System.hs @@ -5,7 +5,9 @@ import Control.Concurrent.MVar import Control.Concurrent.Thread import Control.Concurrent.SafePrint +import Control.Concurrent.STM import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Exception import Data.Maybe import Eventloop.Module.Websocket.Keyboard.Types @@ -20,16 +22,15 @@ import Eventloop.Types.Common import Eventloop.Types.Events import Eventloop.Types.Exception -import qualified Eventloop.Utility.Websockets as WS -import qualified Eventloop.Utility.BufferedWebsockets as BWS +import Eventloop.Utility.Websockets -type Initializer = SharedIOState -> IO (SharedIOState, IOState) -type EventRetriever = SharedIOState -> IOState -> IO (SharedIOState, IOState, [In]) -type PreProcessor = SharedIOState -> IOState -> In -> IO (SharedIOState, IOState, [In]) -type PostProcessor = SharedIOState -> IOState -> Out -> IO (SharedIOState, IOState, [Out]) -type EventSender = SharedIOState -> IOState -> Out -> IO (SharedIOState, IOState) -type Teardown = SharedIOState -> IOState -> IO SharedIOState +type Initializer = SharedIOConstants -> SharedIOState -> IO (SharedIOConstants, SharedIOState, IOConstants, IOState) +type EventRetriever = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> IO [In] +type PreProcessor = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> In -> IO [In] +type PostProcessor = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> Out -> IO [Out] +type EventSender = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> Out -> IO () +type Teardown = SharedIOConstants -> SharedIOState -> IOConstants -> IOState -> IO SharedIOState type OutEventRouter = Out -> EventloopModuleIdentifier @@ -40,7 +41,8 @@ -- System Configurations data EventloopModuleConfiguration = EventloopModuleConfiguration { moduleId :: EventloopModuleIdentifier - , iostateM :: MVar IOState + , ioConstants :: IOConstants + , ioStateT :: TVar IOState , initializerM :: Maybe Initializer , retrieverM :: Maybe EventRetriever , preprocessorM :: Maybe PreProcessor @@ -57,7 +59,7 @@ data EventloopConfiguration progstateT - = EventloopConfiguration { progstateM :: MVar progstateT + = EventloopConfiguration { progstateT :: TVar progstateT , eventloopFunc :: progstateT -> In -> (progstateT, [Out]) , inEventQueue :: InEventQueue , outEventQueue :: OutEventQueue @@ -67,12 +69,13 @@ data EventloopSystemConfiguration progstateT = EventloopSystemConfiguration { eventloopConfig :: EventloopConfiguration progstateT , moduleConfigs :: [EventloopModuleConfiguration] - , sharedIOStateM :: MVar SharedIOState + , sharedIOConstants :: SharedIOConstants + , sharedIOStateT :: TVar SharedIOState , systemThreadId :: ThreadId , retrieverThreadsM :: MVar [Thread] , outRouterThreadM :: MVar Thread , senderThreadsM :: MVar [Thread] - , exceptions :: ExceptionCollection EventloopException + , exceptions :: ExceptionCollection SomeException , isStoppingM :: MVar Bool } @@ -96,42 +99,39 @@ -- Shared IO State -data SharedIOState = SharedIOState { safePrintToken :: SafePrintToken - , measureText :: CanvasText -> IO ScreenDimensions - } +data SharedIOConstants = SharedIOConstants { safePrintToken :: SafePrintToken + , measureText :: CanvasText -> IO ScreenDimensions + } +data SharedIOState = SharedIOState {} -- Modules IO State -data IOState = MouseState { receiveBuffer :: BWS.BufferedReceiveBuffer - , clientSocket :: BWS.ClientSocket - , clientConnection :: BWS.Connection - , serverSocket :: BWS.ServerSocket - , bufferedReaderThread :: BWS.BufferedReaderThread - } - | KeyboardState { receiveBuffer :: BWS.BufferedReceiveBuffer - , clientSocket :: BWS.ClientSocket - , clientConnection :: BWS.Connection - , serverSocket :: BWS.ServerSocket - , bufferedReaderThread :: BWS.BufferedReaderThread - } - | CanvasState { commonReceiveBuffer :: WS.ReceiveBuffer - , canvasUserReceiveBuffer :: CanvasUserReceiveBuffer - , canvasSystemReceiveBuffer :: CanvasSystemReceiveBuffer - , clientSocket :: WS.ClientSocket - , clientConnection :: WS.Connection - , serverSocket :: WS.ServerSocket - , unbufferedReaderThread :: WS.UnbufferedReaderThread - , routerThread :: Thread - } - | StdInState { newStdInInEvents :: [StdInIn] - } - | TimerState { startedIntervalTimers :: [StartedTimer] +data IOConstants = MouseConstants { clientSocket :: ClientSocket + , clientConnection :: Connection + , serverSocket :: ServerSocket + } + | KeyboardConstants { clientSocket :: ClientSocket + , clientConnection :: Connection + , serverSocket :: ServerSocket + } + | CanvasConstants { canvasSystemReceiveBuffer :: CanvasSystemReceiveBuffer + , clientSocket :: ClientSocket + , clientConnection :: Connection + , serverSocket :: ServerSocket + } + | StdInConstants { stdInInQueue :: BlockingConcurrentQueue StdInIn + } + | TimerConstants { tickInQueue :: BlockingConcurrentQueue TimerIn + } + | FileConstants { fileInQueue :: BlockingConcurrentQueue FileIn + } + | NoConstants + deriving Show + +data IOState = TimerState { startedIntervalTimers :: [StartedTimer] , startedTimers :: [StartedTimer] - , incomingIntervalTickBuffer :: IncomingTickBuffer - , incomingTickBuffer :: IncomingTickBuffer } - | FileState { newFileInEvents :: [FileIn] - , opened :: [OpenFile] + | FileState { opened :: [OpenFile] } | StatefulGraphicsState { states :: GraphicsStates } - | NoState + | NoState diff --git a/src/Eventloop/Utility/BufferedWebsockets.hs b/src/Eventloop/Utility/BufferedWebsockets.hs deleted file mode 100644 --- a/src/Eventloop/Utility/BufferedWebsockets.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Eventloop.Utility.BufferedWebsockets - ( module Eventloop.Utility.Websockets - , module Eventloop.Utility.BufferedWebsockets - ) where - - - -import qualified Data.Text as T -import qualified Network.Socket as S -import Network.WebSockets hiding (Message) -import Control.Concurrent.MVar -import Control.Concurrent -import Control.Exception - -import Control.Concurrent.Thread - -import Eventloop.Utility.Websockets hiding ( ReceiveBuffer - , setupWebsocketConnection - , spawnReader - , readIntoBuffer - , hasMessage - , takeMessage - ) - -type BufferedReceiveBuffer = MVar [Message] -type BufferedReaderThread = ReaderThread - -setupWebsocketConnection :: Host -> Port -> IO (BufferedReceiveBuffer, ClientSocket, Connection, ServerSocket, ReaderThread) -setupWebsocketConnection host port - = do - serverSocket <- createBindListenServerSocket host port - (clientConnection, clientSocket) <- acceptFirstConnection serverSocket - recvBuffer <- newMVar [] - readerThread <- spawnBufferedReader recvBuffer clientConnection clientSocket - return (recvBuffer, clientSocket, clientConnection, serverSocket, readerThread) - - -spawnBufferedReader :: BufferedReceiveBuffer -> Connection -> ClientSocket -> IO BufferedReaderThread -spawnBufferedReader recvBuffer conn clientSocket - = forkThread (handle (handleCloseRequestException clientSocket) $ bufferedReadIntoBuffer recvBuffer conn) - - -bufferedReadIntoBuffer :: BufferedReceiveBuffer -> Connection -> IO () -bufferedReadIntoBuffer recvBuffer conn = do - textMessage <- receiveData conn - let - message = T.unpack textMessage - messages <- takeMVar recvBuffer - putMVar recvBuffer (messages ++ [message]) - bufferedReadIntoBuffer recvBuffer conn - - -hasMessages :: BufferedReceiveBuffer -> IO Bool -hasMessages recvBuffer = do - messages <- readMVar recvBuffer - return ((length messages) > 0) - -takeMessages :: BufferedReceiveBuffer -> IO [Message] -takeMessages recvBuffer = do - messages <- takeMVar recvBuffer - putMVar recvBuffer [] - return messages diff --git a/src/Eventloop/Utility/Websockets.hs b/src/Eventloop/Utility/Websockets.hs --- a/src/Eventloop/Utility/Websockets.hs +++ b/src/Eventloop/Utility/Websockets.hs @@ -6,13 +6,15 @@ import qualified Network.Socket as S import qualified Data.Text as T import Network.WebSockets hiding (Message) -import Control.Concurrent.MVar import Control.Concurrent +import Control.Concurrent.MVar +import Control.Concurrent.SafePrint +import Control.Concurrent.Thread import Control.Exception import Data.ByteString.Lazy -import Control.Concurrent.Thread + type Host = [Char] type Port = Int type Message = [Char] @@ -24,6 +26,8 @@ type ReaderThread = Thread type UnbufferedReaderThread = ReaderThread +instance Show Connection where + show _ = "Connection" createBindListenServerSocket :: Host -> Port -> IO ServerSocket createBindListenServerSocket host port = do @@ -43,89 +47,82 @@ return (connection, clientSocket) -setupWebsocketConnection :: Host -> Port -> IO (ReceiveBuffer, ClientSocket, Connection, ServerSocket, UnbufferedReaderThread) +setupWebsocketConnection :: Host -> Port -> IO (ClientSocket, Connection, ServerSocket) setupWebsocketConnection host port = S.withSocketsDo $ do serverSocket <- createBindListenServerSocket host port (clientConnection, clientSocket) <- acceptFirstConnection serverSocket - recvBuffer <- newEmptyMVar - readerThread <- spawnUnbufferedReader recvBuffer clientConnection clientSocket - return (recvBuffer, clientSocket, clientConnection, serverSocket, readerThread) - + return (clientSocket, clientConnection, serverSocket) -spawnUnbufferedReader :: ReceiveBuffer -> Connection -> ClientSocket -> IO UnbufferedReaderThread -spawnUnbufferedReader recvBuffer conn clientSocket - = forkThread (handle (handleCloseRequestException clientSocket) $ readIntoBuffer recvBuffer conn) - - -readIntoBuffer :: ReceiveBuffer -> Connection -> IO () -readIntoBuffer recvBuffer conn = do - textMessage <- receiveData conn - let - message = T.unpack textMessage - putMVar recvBuffer message - readIntoBuffer recvBuffer conn - - -handleCloseRequestException :: ClientSocket -> ConnectionException -> IO () -handleCloseRequestException clientSocket (CloseRequest i reason) + +handleCloseRequestException :: ClientSocket -> SafePrintToken -> ConnectionException -> IO (Maybe Message) +handleCloseRequestException clientSocket safePrintToken (CloseRequest i reason) | i == 1000 = do - Prelude.putStrLn "Client connected was closed elegantly." + safePrintLn safePrintToken "Client connection was closed elegantly." S.sClose clientSocket + return Nothing | otherwise = do - Prelude.putStrLn ("Connection was closed but reason unknown: " ++ show i ++ " " ++ show reason) + safePrintLn safePrintToken ("Connection was closed but reason unknown: " ++ show i ++ " " ++ show reason) S.sClose clientSocket + return Nothing -handleCloseRequestException clientSocket (ConnectionClosed) +handleCloseRequestException clientSocket safePrintToken (ConnectionClosed) = do - Prelude.putStrLn ("Connection was closed unexpectedly") + safePrintLn safePrintToken ("Connection was closed unexpectedly") S.sClose clientSocket throw ConnectionClosed -handleCloseRequestException clientSocket (ParseException text) +handleCloseRequestException clientSocket safePrintToken (ParseException text) = do - Prelude.putStrLn ("Parse exception on message: " ++ text) + safePrintLn safePrintToken ("Parse exception on message: " ++ text) S.sClose clientSocket throw (ParseException text) - -hasMessage :: ReceiveBuffer -> IO Bool -hasMessage recvBuffer = do - buffer <- tryReadMVar recvBuffer - return (buffer /= Nothing) - - -takeMessage :: ReceiveBuffer -> IO Message -takeMessage recvBuffer = takeMVar recvBuffer + +takeMessage :: SafePrintToken -> ClientSocket -> Connection -> IO (Maybe Message) +takeMessage safePrintToken sock conn + = handle (handleCloseRequestException sock safePrintToken) $ do + textMessage <- receiveData conn + let + message = T.unpack textMessage + return (Just message) writeMessage :: Connection -> Message -> IO () -writeMessage conn message = sendTextData conn (T.pack message) - +writeMessage conn message = do + sendTextData conn (T.pack message) writeBinaryMessage :: Connection -> ByteString -> IO () writeBinaryMessage conn message = sendBinaryData conn message -closeWebsocketConnection :: ServerSocket -> ClientSocket -> Connection -> ReaderThread -> IO () -closeWebsocketConnection serverSocket clientSocket clientConnection readerThread +isConnected :: S.Socket -> IO Bool +isConnected sock = S.sIsConnected sock + +closeWebsocketConnection :: SafePrintToken -> ServerSocket -> ClientSocket -> Connection -> IO () +closeWebsocketConnection safePrintToken serverSocket clientSocket clientConnection = do S.sClose serverSocket - isConnected <- S.sIsConnected clientSocket + isConnected <- isConnected clientSocket case isConnected of - False -> Prelude.putStrLn "Tried to close client connection but was already closed" + False -> safePrintLn safePrintToken "Tried to close client connection but was already closed" True -> do - Prelude.putStrLn "Closing client connection..." + safePrintLn safePrintToken "Closing client connection..." handle (\(exception) -> case (exception :: ConnectionException) of ConnectionClosed -> do - Prelude.putStrLn "Socket still open, but stream had an error" + safePrintLn safePrintToken "Socket still open, but stream had an error" S.sClose clientSocket - Prelude.putStrLn "Client connection closed!" - _ -> Prelude.putStrLn "this should never happen, contact an administrator! ERROR: WS 01" + safePrintLn safePrintToken "Client connection closed!" + _ -> safePrintLn safePrintToken "this should never happen, contact an administrator! ERROR: WS 01" ) ( sendClose clientConnection (T.pack "Shutting down..") ) - joinThread readerThread - + + +destroyWebsocketConnection :: ServerSocket -> ClientSocket -> IO () +destroyWebsocketConnection serverSocket clientSocket + = do + S.close serverSocket + S.close clientSocket