eventloop 0.4.1.2 → 0.5.0.0
raw patch · 34 files changed
+1330/−683 lines, 34 filesdep +concurrent-utilitiesdep ~base
Dependencies added: concurrent-utilities
Dependency ranges changed: base
Files
- eventloop.cabal +35/−17
- src/Eventloop/Core.hs +219/−0
- src/Eventloop/DefaultConfiguration.hs +28/−27
- src/Eventloop/EventloopCore.hs +0/−277
- src/Eventloop/Module/BasicShapes/BasicShapes.hs +15/−11
- src/Eventloop/Module/DrawTrees/DrawTrees.hs +18/−12
- src/Eventloop/Module/File/File.hs +24/−20
- src/Eventloop/Module/Graphs/Graphs.hs +21/−24
- src/Eventloop/Module/StdIn/StdIn.hs +30/−21
- src/Eventloop/Module/StdOut/StdOut.hs +10/−7
- src/Eventloop/Module/Timer/Timer.hs +9/−12
- src/Eventloop/Module/Websocket/Canvas/Canvas.hs +36/−26
- src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs +17/−18
- src/Eventloop/Module/Websocket/Mouse/Mouse.hs +19/−20
- src/Eventloop/OutRouter.hs +19/−0
- src/Eventloop/RouteEvent.hs +0/−18
- src/Eventloop/System/DisplayExceptionThread.hs +21/−0
- src/Eventloop/System/EventloopThread.hs +79/−0
- src/Eventloop/System/InitializationThread.hs +36/−0
- src/Eventloop/System/OutRouterThread.hs +68/−0
- src/Eventloop/System/Processing.hs +80/−0
- src/Eventloop/System/RetrieverThread.hs +44/−0
- src/Eventloop/System/SenderThread.hs +47/−0
- src/Eventloop/System/Setup.hs +87/−0
- src/Eventloop/System/TeardownThread.hs +36/−0
- src/Eventloop/System/ThreadActions.hs +86/−0
- src/Eventloop/Types/Common.hs +3/−0
- src/Eventloop/Types/EventTypes.hs +0/−121
- src/Eventloop/Types/Events.hs +35/−0
- src/Eventloop/Types/Exception.hs +68/−0
- src/Eventloop/Types/System.hs +134/−0
- src/Eventloop/Utility/BufferedWebsockets.hs +2/−2
- src/Eventloop/Utility/Concurrent.hs +0/−44
- src/Eventloop/Utility/Websockets.hs +4/−6
eventloop.cabal view
@@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.1.2 +version: 0.5.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), @@ -24,20 +24,16 @@ license-file: LICENSE author: Sebastiaan la Fleur maintainer: sebastiaan.la.fleur@gmail.com -copyright: University of Twente 2015 | Sebastiaan la Fleur 2015 +copyright: University of Twente 2015 | Sebastiaan la Fleur 2015 category: Eventloop build-type: Simple -- extra-source-files: cabal-version: >=1.10 library - exposed-modules: Eventloop.EventloopCore, - Eventloop.Types.EventTypes, - Eventloop.Types.Common, - Eventloop.Utility.Vectors, - Eventloop.Utility.Trees.GeneralTree, - Eventloop.RouteEvent, + exposed-modules: Eventloop.Core, Eventloop.DefaultConfiguration, + Eventloop.Module.Websocket.Canvas, Eventloop.Module.Websocket.Keyboard, Eventloop.Module.Websocket.Mouse, @@ -47,14 +43,17 @@ Eventloop.Module.StdIn, Eventloop.Module.StdOut, Eventloop.Module.Timer, - Eventloop.Module.Graphs + Eventloop.Module.Graphs, + + Eventloop.Types.Common, + Eventloop.Types.Events, + Eventloop.Types.System, + + Eventloop.Utility.Vectors, + Eventloop.Utility.Trees.GeneralTree -- Modules included in this library but not exported. - other-modules: Eventloop.Utility.Websockets, - Eventloop.Utility.BufferedWebsockets, - Eventloop.Utility.Config, - Eventloop.Utility.Trees.LayoutTree, - Eventloop.Utility.Concurrent, + other-modules: Eventloop.OutRouter, Eventloop.Module.Websocket.Canvas.Canvas, Eventloop.Module.Websocket.Canvas.JSONEncoding, Eventloop.Module.Websocket.Canvas.Opcode, @@ -77,18 +76,37 @@ Eventloop.Module.Timer.Timer, Eventloop.Module.Timer.Types, Eventloop.Module.Graphs.Graphs, - Eventloop.Module.Graphs.Types + Eventloop.Module.Graphs.Types, + + Eventloop.System.DisplayExceptionThread, + Eventloop.System.EventloopThread, + Eventloop.System.InitializationThread, + Eventloop.System.OutRouterThread, + Eventloop.System.Processing, + Eventloop.System.RetrieverThread, + 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 other-extensions: OverloadedStrings - build-depends: base >=4.7 && <4.9, + build-depends: base >=4.8 && <4.9, network >=2.6 && <2.7, text >=1.2 && <1.3, websockets >=0.9 && <0.10, timers >=0.2 && <0.3, suspend >=0.2 && <0.3, aeson >=0.8 && <0.9, - bytestring >=0.10 && <0.11 + bytestring >=0.10 && <0.11, + concurrent-utilities >=0.1 && <0.2 -- Directories containing source files. hs-source-dirs: src
+ src/Eventloop/Core.hs view
@@ -0,0 +1,219 @@+module Eventloop.Core where + +import Control.Exception +import Control.Concurrent.MVar +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.Suspend.Lifted +import Control.Concurrent.Thread +import Control.Concurrent.Timer +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.System.DisplayExceptionThread +import Eventloop.System.EventloopThread +import Eventloop.System.InitializationThread +import Eventloop.System.OutRouterThread +import Eventloop.System.RetrieverThread +import Eventloop.System.SenderThread +import Eventloop.System.Setup +import Eventloop.System.TeardownThread +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Types.System + + + +{- | Starts the entire system. First the setup phase is handled to setup the different +concurrent resources. This is followed by the initialization phase where all modules are initialised. +Than, the different worker threads are spawned and finally the system thread will go to work as the eventloop thread. + +Shutting down is handled centrally through the system thread (main thread). +If any of the threads(including the system thread) receive an exception, only the first exception is thrown to the system +thread which will try to shutdown immediately. This exception is logged by the system thread. +All other exceptions are logged by their respective threads. The system thread will than shutdown the worker +threads. This is done by throwing exceptions to all workerthreads except sender threads. These are sent a Stop event. +If they take longer than 1 second, to finish up, they will also be thrown an exception. +-} +startEventloopSystem :: EventloopSetupConfiguration progstateT + -> 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 + + -- 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 + + -- 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 + + -- Clean up the system + startTeardowning systemconfig + startDisplayingExceptions systemconfig + ) + +terminateWithinOrThrowException :: Int + -> SomeException + -> Thread + -> IO TimerIO +terminateWithinOrThrowException delay e t + = oneShotTimer ( do + term <- isTerminated t + case term of + True -> return () + False -> throwTo (getThreadId t) e + ) + ((usDelay.fromIntegral) delay) + +{- | +Utility function in order to create the different thread actions in the system. +Assumed is that the action requires the system configuration, the module configuration and some resource +that may be available in the module configuration. +-} +threadActionsBasedOnModule :: EventloopSystemConfiguration progstateT + -> (EventloopSystemConfiguration progstateT -> (EventloopModuleConfiguration, resource) -> IO ()) + -> (EventloopModuleConfiguration -> Maybe resource) + -> [EventloopModuleConfiguration] + -> [IO ()] +threadActionsBasedOnModule _ _ _ [] = [] +threadActionsBasedOnModule systemconfig action getResourceFunc (moduleConfig:mcs) + = case (getResourceFunc moduleConfig) of + Nothing -> otherThreadActions + (Just resource) -> (action systemconfig (moduleConfig, resource)):otherThreadActions + where + otherThreadActions = threadActionsBasedOnModule systemconfig action getResourceFunc mcs + + +spawnWorkerThread :: EventloopSystemConfiguration progstateT + -> (EventloopSystemConfiguration progstateT -> Thread -> IO ()) + -> IO () + -> IO () +spawnWorkerThread systemconfig logAction action + = do + thread <- forkThread $ do + catch action + ( \exception -> + case exception of + ShuttingDownException -> + return () + _ -> do + isStopping <- takeMVar isStoppingM_ + putMVar isStoppingM_ True + case isStopping of + True -> do + case exception of + RequestShutdownException -> return () + _ -> logException exceptions_ exception + False -> throwTo systemTid exception + ) + logAction systemconfig thread + + where + exceptions_ = exceptions systemconfig + systemTid = systemThreadId systemconfig + isStoppingM_ = isStoppingM systemconfig + + +registerRetrieverThread :: EventloopSystemConfiguration progstateT + -> Thread + -> IO () +registerRetrieverThread systemconfig thread + = do + retrieverThreads <- takeMVar retrieverThreadsM_ + putMVar retrieverThreadsM_ (retrieverThreads ++ [thread]) + where + retrieverThreadsM_ = retrieverThreadsM systemconfig + + +registerOutRouterThread :: EventloopSystemConfiguration progstateT + -> Thread + -> IO () +registerOutRouterThread systemconfig thread + = putMVar (outRouterThreadM systemconfig) thread + + +registerSenderThread :: EventloopSystemConfiguration progstateT + -> Thread + -> IO () +registerSenderThread systemconfig thread + = do + senderThreads <- takeMVar senderThreadsM_ + putMVar senderThreadsM_ (senderThreads ++ [thread]) + where + senderThreadsM_ = senderThreadsM systemconfig + + +throwShutdownExceptionToThread :: Thread -> IO () +throwShutdownExceptionToThread thread + = throwTo (getThreadId thread) ShuttingDownException + + +allWorkerThreads :: EventloopSystemConfiguration progstateT + -> IO [Thread] +allWorkerThreads systemconfig + = do + retrievers <- retrieverThreads systemconfig + outRouter <- outRouterThread systemconfig + senders <- senderThreads systemconfig + return (retrievers ++ outRouter ++ senders) + + +retrieverThreads :: EventloopSystemConfiguration progstateT + -> IO [Thread] +retrieverThreads systemconfig + = readMVar retrieverThreadsM_ + where + retrieverThreadsM_ = retrieverThreadsM systemconfig + + +outRouterThread :: EventloopSystemConfiguration progstateT + -> IO [Thread] +outRouterThread systemconfig + = do + hasNotOutRouterThread <- isEmptyMVar outRouterThreadM_ + case hasNotOutRouterThread of + True -> return [] + False -> do + outRouterThread <- readMVar outRouterThreadM_ + return [outRouterThread] + where + outRouterThreadM_ = outRouterThreadM systemconfig + + +senderThreads :: EventloopSystemConfiguration progstateT + -> IO [Thread] +senderThreads systemconfig + = readMVar senderThreadsM_ + where + senderThreadsM_ = senderThreadsM systemconfig
src/Eventloop/DefaultConfiguration.hs view
@@ -1,8 +1,6 @@ module Eventloop.DefaultConfiguration where -import Eventloop.EventloopCore -import Eventloop.Types.EventTypes -import Eventloop.RouteEvent +import Control.Concurrent.SafePrint import Eventloop.Module.Websocket.Keyboard import Eventloop.Module.Websocket.Mouse @@ -10,29 +8,32 @@ import Eventloop.Module.StdOut import Eventloop.Module.StdIn import Eventloop.Module.Timer - +import Eventloop.Types.Events +import Eventloop.Types.System -allModulesEventloopConfiguration :: progstateT -> {- Begin program state -} - (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -} - EventloopConfiguration progstateT -allModulesEventloopConfiguration beginProgstate eventloop = (EventloopConfiguration - -- Begin program state - beginProgstate - -- Eventloop function - eventloop - -- OutEvent Router - routeOutEvent - -- SharedIOState - defaultSharedIOState - -- All module configurations - [ defaultFileModuleConfiguration - , defaultTimerModuleConfiguration - , defaultKeyboardModuleConfiguration - , defaultMouseModuleConfiguration - , defaultStdInModuleConfiguration - , defaultStdOutModuleConfiguration - ] - ) +allModulesEventloopSetupConfiguration :: progstateT -> {- Begin program state -} + (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -} + EventloopSetupConfiguration progstateT +allModulesEventloopSetupConfiguration beginProgstate eventloop + = ( EventloopSetupConfiguration + -- Begin program state + beginProgstate + + -- Eventloop function + eventloop + + -- All module setupconfigurations + [ setupFileModuleConfiguration + , setupTimerModuleConfiguration + , setupKeyboardModuleConfiguration + , setupMouseModuleConfiguration + , setupStdInModuleConfiguration + , setupStdOutModuleConfiguration + ] + ) -defaultSharedIOState :: SharedIOState -defaultSharedIOState = SharedIOState undefined+setupSharedIOState :: IO SharedIOState +setupSharedIOState + = do + safePrintToken <- createSafePrintToken + return (SharedIOState safePrintToken undefined)
− src/Eventloop/EventloopCore.hs
@@ -1,277 +0,0 @@-module Eventloop.EventloopCore - ( startMainloop - ) where - -import Eventloop.Types.EventTypes - -import Data.Maybe -import Control.Exception -import Control.Concurrent - -type HasToStop = Bool -type PhaseDescription = [Char] -type ProcessingDescription = [Char] - -putStrLnIf :: Bool -> String -> IO () -putStrLnIf doIf str | doIf = putStrLn str - | otherwise = return () - - -startMainloop :: EventloopConfiguration progstateT -> IO () -startMainloop eventloopConfig - = do - (eventloopConfig', initHasToStop) <- initialisePhase eventloopConfig - case initHasToStop of - True -> do - putStrLn "Something went wrong during initialisation" - (_, emTeardownHasToStop) <- teardownPhase eventloopConfig' - putStrLnIf emTeardownHasToStop "Something also went wrong at teardown" - False -> do - eventloopConfig'' <- startMainloopWithStart eventloopConfig' - (eventloopConfig''', teardownHasToStop) <- teardownPhase eventloopConfig'' - putStrLnIf teardownHasToStop "Something went wrong during teardown" - putStrLn "Stopping system..." - - -initialisePhase :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop) -initialisePhase eventloopConfig - = do - let - sharedIO = sharedIOState eventloopConfig - moduleConfigs = moduleConfigurations eventloopConfig - (sharedIO', moduleConfigs', hasToStop) <- handlePhaseModuleConfigurations sharedIO moduleConfigs initializer "initialisation" - return (eventloopConfig {sharedIOState = sharedIO', moduleConfigurations = moduleConfigs'}, hasToStop) - - -teardownPhase :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop) -teardownPhase eventloopConfig - = do - let - sharedIO = sharedIOState eventloopConfig - moduleConfigs = moduleConfigurations eventloopConfig - (sharedIO', moduleConfigs', hasToStop) <- handlePhaseModuleConfigurations sharedIO moduleConfigs teardown "teardown" - return (eventloopConfig {sharedIOState = sharedIO', moduleConfigurations = moduleConfigs'}, hasToStop) - - -handlePhaseModuleConfigurations :: SharedIOState - -> [EventloopModuleConfiguration] - -> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) - -> PhaseDescription - -> IO (SharedIOState, [EventloopModuleConfiguration], HasToStop) -handlePhaseModuleConfigurations sharedIO [] _ _ = return (sharedIO, [], False) -handlePhaseModuleConfigurations sharedIO (mc:mcs) phaseFunc phaseDescription - = do - (sharedIO', mc', hasToStop) <- handlePhaseModuleConfiguration sharedIO mc phaseFunc phaseDescription - (sharedIO'', mcs', hasToStopOther) <- handlePhaseModuleConfigurations sharedIO' mcs phaseFunc phaseDescription - return (sharedIO'', mc':mcs', hasToStop || hasToStopOther) - - -handlePhaseModuleConfiguration :: SharedIOState - -> EventloopModuleConfiguration - -> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) - -> PhaseDescription - -> IO (SharedIOState, EventloopModuleConfiguration, HasToStop) -handlePhaseModuleConfiguration sharedIO mc phaseFunc phaseDescription - = do - let - name = moduleIdentifier mc - modulePhaseFuncM = phaseFunc mc - moduleIOState = iostate mc - handle - ( \exception -> do - putStrLn ("Exception during " ++ phaseDescription ++ " in module " ++ name) - putStrLn (" " ++ show (exception :: SomeException)) - return (sharedIO, mc, True) - ) - ( case modulePhaseFuncM of - (Just modulePhaseFunc) -> do - (sharedIO', moduleIOState') <- modulePhaseFunc sharedIO moduleIOState - return (sharedIO', mc {iostate=moduleIOState'}, False) - Nothing -> return (sharedIO, mc, False) - ) - - -startMainloopWithStart :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT) -startMainloopWithStart ec = handleMainloopUsingSource (return (ec, [Start], False)) - - -handleMainloopUsingSource :: IO (EventloopConfiguration progstateT, [In], HasToStop) -> IO (EventloopConfiguration progstateT) -handleMainloopUsingSource source = do - (ec', inEvents, hasToStopSource) <- source - case hasToStopSource of - True -> return ec' - False -> do - (ec'', inEvents', hasToStopPreProcess) <- processEvents "preprocess" ec' preprocessor inEvents -- Do preprocess step - case hasToStopPreProcess of - True -> return ec'' - False -> do - (ec''', hasToStopInEvents) <- handleInEvents inEvents' ec'' - case hasToStopInEvents of - True -> return ec''' - False -> handleMainloopUsingSource (receiveEvents ec''') - - -receiveEvents :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, [In], HasToStop) -receiveEvents eventloopConfig = do - let - (moduleConfig:mcs) = moduleConfigurations eventloopConfig - eventRetrieverM = eventRetriever moduleConfig - sharedIO = sharedIOState eventloopConfig - checkNextModule sio mc = do - threadDelay 100000 - receiveEvents (eventloopConfig {moduleConfigurations=(mcs++[mc]), sharedIOState=sio}) - case eventRetrieverM of - Nothing -> checkNextModule sharedIO moduleConfig - Just er -> handle - ( \exception -> do - putStrLn "Exception when receiving events" - putStrLn (" " ++ show (exception :: SomeException)) - return (eventloopConfig, [], True) - ) - ( do - (sharedIO', iostate', inEvents) <- er sharedIO (iostate moduleConfig) - let - moduleConfig' = moduleConfig {iostate=iostate'} - case inEvents of - [] -> checkNextModule sharedIO' moduleConfig' - _ -> return (eventloopConfig {moduleConfigurations=(mcs++[moduleConfig']), sharedIOState=sharedIO'}, inEvents, False) - ) - - -handleInEvents :: [In] -> EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop) -handleInEvents [] ec - = return (ec, False) - -handleInEvents (i:is) ec - = do - (ec', hasToStop) <- handleSingleInEvent i ec - case hasToStop of - True -> return (ec', True) - False -> handleInEvents is ec' - - -handleSingleInEvent :: In -> EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, HasToStop) -handleSingleInEvent inEvent ec - = handle - ( \exception -> do - putStrLn "Exception in eventloop function" - putStrLn (" " ++ show (exception :: SomeException)) - return (ec, True) - ) - ( do - let - (ec', outEvents) = doEventloop ec inEvent -- Do eventloop step - (ec'', outEvents', hasToStopPostProcess) <- processEvents "postprocess" ec' postprocessor outEvents -- Do postprocess step - case hasToStopPostProcess of - False -> sendOutEvents ec'' outEvents' -- Do send outEvents step - True -> do - putStrLn "Exception when postprocessing outEvents" - return (ec'', True) - ) - - -doEventloop :: EventloopConfiguration progstateT -> In -> (EventloopConfiguration progstateT, [Out]) -doEventloop ec inEvent = (ec', outEvents) - where - (progState', outEvents) = (eventloopFunc ec) (progState ec) inEvent - ec' = ec {progState = progState'} - - -sendOutEvents :: EventloopConfiguration progstateT -> [Out] -> IO (EventloopConfiguration progstateT, HasToStop) -sendOutEvents ec [] = return (ec, False) -sendOutEvents ec (Stop:_) = return (ec, True) -sendOutEvents ec (out:outs) - = handle - ( \exception -> do - putStrLn "Exception when sending outEvent" - putStrLn (" OutEvent: " ++ show out) - putStrLn (" Exception: " ++ show (exception :: SomeException)) - return (ec, True) - ) - ( do - let - moduleConfigs = moduleConfigurations ec - moduleToSendWith = (outRouter ec) out - sharedIO = sharedIOState ec - (sharedIO', moduleConfigs') <- sendOutEventWithModule sharedIO moduleToSendWith out moduleConfigs - let - ec' = ec {sharedIOState=sharedIO', moduleConfigurations=moduleConfigs'} - sendOutEvents ec' outs - ) - - -sendOutEventWithModule :: SharedIOState -> EventloopModuleIdentifier -> Out -> [EventloopModuleConfiguration] -> IO (SharedIOState, [EventloopModuleConfiguration]) -sendOutEventWithModule _ sendWith out [] - = error ("Could not send outEvent because module is not configured. Wanted to use module: " ++ (show sendWith) ++ " Event: " ++ (show out)) - -sendOutEventWithModule sharedIO sendWith out (mc:mcs) - | sendWith == moduleId = case eventSenderFuncM of - Nothing -> error ("Could not send outEvent because module " ++ (show sendWith) ++ " does not have an eventsender configured") - Just eventSenderFunc -> do - (sharedIO', moduleIOState') <- eventSenderFunc sharedIO moduleIOState out - return (sharedIO', (mc {iostate=moduleIOState'}):mcs) - | otherwise = do - (sharedIO', mcs') <- sendOutEventWithModule sharedIO sendWith out mcs - return (sharedIO, mc:mcs') - where - moduleId = moduleIdentifier mc - eventSenderFuncM = eventSender mc - moduleIOState = iostate mc - - -processEventModule :: SharedIOState - -> EventloopModuleConfiguration - -> (EventloopModuleConfiguration - -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -- Function from moduleconfig to pre-/postprocess function - -> event - -> IO (SharedIOState, EventloopModuleConfiguration, [event]) -processEventModule sharedIO eventloopModuleConfig getFunc event = do - let - processFuncM = getFunc eventloopModuleConfig - case processFuncM of - Nothing -> return (sharedIO, eventloopModuleConfig, [event]) - Just processFunc -> do - (sharedIO', iostate', events) <- processFunc sharedIO (iostate eventloopModuleConfig) event - return (sharedIO', eventloopModuleConfig {iostate=iostate'}, events) - - -processEventsModules :: ProcessingDescription - -> SharedIOState - -> [EventloopModuleConfiguration] - -> (EventloopModuleConfiguration - -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -- Function from moduleconfig to pre-/postprocess function - -> [event] - -> IO (SharedIOState, [EventloopModuleConfiguration], [event], HasToStop) -processEventsModules _ sharedIO mcs _ [] - = return (sharedIO, mcs, [], False) - -processEventsModules _ sharedIO [] _ events - = return (sharedIO, [], events, False) - -processEventsModules processingDescription sharedIO (moduleConfig:mcs) getFunc (event:events) - = handle - ( \exception -> do - putStrLn ("Exception when " ++ (show processingDescription)) - putStrLn (show (exception :: SomeException)) - return (sharedIO, moduleConfig:mcs, event:events, True) - ) - ( do - (sharedIO', moduleConfig', moreEvents) <- processEventModule sharedIO moduleConfig getFunc event - (sharedIO'', mcs', moreEvents', hasToStopResultingEvents) <- processEventsModules processingDescription sharedIO' mcs getFunc moreEvents - (sharedIO''', mcs'', events', hasToStopOtherEvents) <- processEventsModules processingDescription sharedIO'' (moduleConfig':mcs') getFunc events - return (sharedIO''', mcs'', moreEvents' ++ events', hasToStopResultingEvents || hasToStopOtherEvents) - ) - - -processEvents :: ProcessingDescription - -> EventloopConfiguration progstateT - -> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -- Function from moduleconfig to pre-/postprocess function - -> [event] - -> IO (EventloopConfiguration progstateT, [event], HasToStop) -processEvents processingDescription eventloopConfig getFunc events - = do - let - moduleConfigs = moduleConfigurations eventloopConfig - sharedIO = sharedIOState eventloopConfig - (sharedIO', moduleConfigs', events', hasToStop) <- processEventsModules processingDescription sharedIO moduleConfigs getFunc events - return (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}, events', hasToStop)
src/Eventloop/Module/BasicShapes/BasicShapes.hs view
@@ -1,12 +1,18 @@-module Eventloop.Module.BasicShapes.BasicShapes where +module Eventloop.Module.BasicShapes.BasicShapes + ( setupBasicShapesModuleConfiguration + , basicShapesModuleIdentifier + , basicShapesPostProcessor + ) where import Eventloop.Module.BasicShapes.Types -import Eventloop.Types.EventTypes import Eventloop.Module.BasicShapes.Classes +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System -defaultBasicShapesModuleConfiguration = ( EventloopModuleConfiguration +setupBasicShapesModuleConfiguration :: EventloopSetupModuleConfiguration +setupBasicShapesModuleConfiguration = ( EventloopSetupModuleConfiguration basicShapesModuleIdentifier - defaultBasicShapesModuleIOState Nothing Nothing Nothing @@ -14,10 +20,6 @@ Nothing Nothing ) - - -defaultBasicShapesModuleIOState :: IOState -defaultBasicShapesModuleIOState = NoState basicShapesModuleIdentifier :: EventloopModuleIdentifier @@ -25,7 +27,9 @@ basicShapesPostProcessor :: PostProcessor -basicShapesPostProcessor shared iostate (OutBasicShapes basicShapesOut ) = return (shared, iostate, [OutCanvas canvasOut]) - where - canvasOut = toCanvasOut basicShapesOut +basicShapesPostProcessor shared iostate (OutBasicShapes basicShapesOut) + = return (shared, iostate, [OutCanvas canvasOut]) + where + canvasOut = toCanvasOut basicShapesOut + basicShapesPostProcessor shared iostate out = return (shared, iostate, [out])
src/Eventloop/Module/DrawTrees/DrawTrees.hs view
@@ -1,17 +1,24 @@-module Eventloop.Module.DrawTrees.DrawTrees where +module Eventloop.Module.DrawTrees.DrawTrees + ( setupDrawTreesModuleConfiguration + , drawTreesModuleIdentifier + , drawTreesPostProcessor + , showGeneralTreeList + , rbExampleTree + , roseExampleTree + ) where import Eventloop.Module.DrawTrees.Types import Eventloop.Utility.Trees.LayoutTree import Eventloop.Utility.Trees.GeneralTree import Eventloop.Module.BasicShapes.Types - -import Eventloop.Types.EventTypes +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System -defaultDrawTreesModuleConfiguration :: EventloopModuleConfiguration -defaultDrawTreesModuleConfiguration = ( EventloopModuleConfiguration +setupDrawTreesModuleConfiguration :: EventloopSetupModuleConfiguration +setupDrawTreesModuleConfiguration = ( EventloopSetupModuleConfiguration drawTreesModuleIdentifier - defaultDrawTreesModuleIOState Nothing Nothing Nothing @@ -20,17 +27,16 @@ Nothing ) -defaultDrawTreesModuleIOState :: IOState -defaultDrawTreesModuleIOState = NoState - drawTreesModuleIdentifier :: EventloopModuleIdentifier drawTreesModuleIdentifier = "parseTree" drawTreesPostProcessor :: PostProcessor -drawTreesPostProcessor shared iostate (OutDrawTrees (DrawTrees canvasId trees)) = return (shared, iostate, [OutBasicShapes $ DrawShapes canvasId [shapeTrees]]) - where - (shapeTrees, _, _) = showGeneralTreeList trees +drawTreesPostProcessor shared iostate (OutDrawTrees (DrawTrees canvasId trees)) + = return (shared, iostate, [OutBasicShapes $ DrawShapes canvasId [shapeTrees]]) + where + (shapeTrees, _, _) = showGeneralTreeList trees + drawTreesPostProcessor shared iostate out = return (shared, iostate, [out])
src/Eventloop/Module/File/File.hs view
@@ -1,6 +1,5 @@ module Eventloop.Module.File.File - ( defaultFileModuleConfiguration - , defaultFileModuleIOState + ( setupFileModuleConfiguration , fileModuleIdentifier , fileEventRetriever , fileEventSender @@ -10,39 +9,44 @@ import Data.Maybe import System.IO -import Eventloop.Types.EventTypes import Eventloop.Module.File.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System -defaultFileModuleConfiguration :: EventloopModuleConfiguration -defaultFileModuleConfiguration = ( EventloopModuleConfiguration +setupFileModuleConfiguration :: EventloopSetupModuleConfiguration +setupFileModuleConfiguration = ( EventloopSetupModuleConfiguration fileModuleIdentifier - defaultFileModuleIOState - Nothing + (Just fileInitializer) (Just fileEventRetriever) Nothing Nothing - (Just fileTeardown) (Just fileEventSender) + (Just fileTeardown) ) -defaultFileModuleIOState :: IOState -defaultFileModuleIOState = FileState [] [] - fileModuleIdentifier :: EventloopModuleIdentifier fileModuleIdentifier = "file" + +fileInitializer :: Initializer +fileInitializer sharedIO + = return (sharedIO, FileState [] []) + + fileEventRetriever :: EventRetriever -fileEventRetriever sharedIO filestate@(FileState { newFileInEvents = newFileInEvents - }) = return (sharedIO, filestate', newFileInEvents') - where - newFileInEvents' = [InFile x | x <- newFileInEvents] - filestate' = filestate {newFileInEvents = []} +fileEventRetriever sharedIO fs + = return (sharedIO, fs', newFileInEvents') + where + newFileInEvents' = map InFile (newFileInEvents fs) + fs' = fs {newFileInEvents = []} fileEventSender :: EventSender -fileEventSender sharedIO fileState (OutFile a) = do - fileState' <- fileEventSender' fileState a - return (sharedIO, fileState') +fileEventSender sharedIO fileState (OutFile a) + = do + fileState' <- fileEventSender' fileState a + return (sharedIO, fileState') fileEventSender' :: IOState -> FileOut -> IO IOState @@ -152,7 +156,7 @@ fileTeardown :: Teardown fileTeardown sharedIO fs = do closeAllFiles handles - return (sharedIO, fs {opened=[]}) + return (sharedIO) where handles = map (\(fp, h, iom) -> h) (opened fs)
src/Eventloop/Module/Graphs/Graphs.hs view
@@ -5,15 +5,15 @@ import qualified Eventloop.Module.Websocket.Mouse as M import qualified Eventloop.Module.Websocket.Keyboard as K import qualified Eventloop.Module.BasicShapes as BS -import qualified Eventloop.Types.EventTypes as ET - +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System import Eventloop.Utility.Vectors -defaultGraphsModuleConfiguration :: ET.EventloopModuleConfiguration -defaultGraphsModuleConfiguration = ( ET.EventloopModuleConfiguration +setupGraphsModuleConfiguration :: EventloopSetupModuleConfiguration +setupGraphsModuleConfiguration = ( EventloopSetupModuleConfiguration graphsModuleIdentifier - defaultGraphsModuleIOState Nothing Nothing (Just graphsPreProcessor) @@ -21,11 +21,8 @@ Nothing Nothing ) - -defaultGraphsModuleIOState :: ET.IOState -defaultGraphsModuleIOState = ET.NoState -graphsModuleIdentifier :: ET.EventloopModuleIdentifier +graphsModuleIdentifier :: EventloopModuleIdentifier graphsModuleIdentifier = "graphs" @@ -66,38 +63,38 @@ -- | Abstracts the standardized 'EventLoop.Types.EventTypes' to 'GraphsIn' -graphsPreProcessor :: ET.PreProcessor -graphsPreProcessor shared io (ET.InMouse (M.Mouse M.MouseCanvas 1 event (Point p))) - | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return (shared, io, [ET.InGraphs $ Mouse event p]) +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, []) where (x, y) = p -graphsPreProcessor shared io k@(ET.InKeyboard (K.Key key)) - = return (shared, io, [k, ET.InGraphs $ Key key]) +graphsPreProcessor shared io k@(InKeyboard (K.Key key)) + = return (shared, io, [k, InGraphs $ Key key]) graphsPreProcessor shared io inEvent = return (shared, io, [inEvent]) -- | Abstracts 'GraphsOut' back to 'BasicShapes' and 'Canvas' events -graphsPostProcessor :: ET.PostProcessor -graphsPostProcessor shared io (ET.OutGraphs SetupGraphs) - = return (shared, io, [ ET.OutCanvas $ C.SetupCanvas canvasIdGraphs 1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) - , ET.OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) +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 shared io (ET.OutGraphs (DrawGraph graph)) - = return (shared, io, [ ET.OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas] - , ET.OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes +graphsPostProcessor shared io (OutGraphs (DrawGraph graph)) + = return (shared, io, [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas] + , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes ]) where shapes = graphToShapes graph -graphsPostProcessor shared io (ET.OutGraphs (Instructions is)) - = return (shared, io, [ ET.OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas] - , ET.OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes +graphsPostProcessor shared io (OutGraphs (Instructions is)) + = return (shared, io, [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas] + , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes ]) where startPLine = Point (0, 0)
src/Eventloop/Module/StdIn/StdIn.hs view
@@ -1,7 +1,7 @@ module Eventloop.Module.StdIn.StdIn - ( defaultStdInModuleConfiguration - , defaultStdInModuleIOState + ( setupStdInModuleConfiguration , stdInModuleIdentifier + , stdInInitializer , stdInEventRetriever , stdInEventSender ) where @@ -9,42 +9,51 @@ import System.IO import Data.String -import Eventloop.Types.EventTypes import Eventloop.Module.StdIn.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System -defaultStdInModuleConfiguration :: EventloopModuleConfiguration -defaultStdInModuleConfiguration = ( EventloopModuleConfiguration +setupStdInModuleConfiguration :: EventloopSetupModuleConfiguration +setupStdInModuleConfiguration = ( EventloopSetupModuleConfiguration stdInModuleIdentifier - defaultStdInModuleIOState - Nothing + (Just stdInInitializer) (Just stdInEventRetriever) Nothing Nothing - Nothing (Just stdInEventSender) + Nothing ) - -defaultStdInModuleIOState :: IOState -defaultStdInModuleIOState = StdInState [] + stdInModuleIdentifier :: EventloopModuleIdentifier stdInModuleIdentifier = "stdin" +stdInInitializer :: Initializer +stdInInitializer sharedIO + = return (sharedIO, StdInState []) + + stdInEventRetriever :: EventRetriever -stdInEventRetriever sharedIO (StdInState events) = return (sharedIO, StdInState [], inEvents) - where - inEvents = map InStdIn events +stdInEventRetriever sharedIO (StdInState events) + = return (sharedIO, StdInState [], inEvents) + where + inEvents = map InStdIn events + stdInEventSender :: EventSender -stdInEventSender sharedIO stdInState (OutStdIn a) = do - stdInState' <- stdInEventSender' stdInState a - return (sharedIO, stdInState') - +stdInEventSender sharedIO stdInState (OutStdIn a) + = do + stdInState' <- stdInEventSender' stdInState a + return (sharedIO, stdInState') + + stdInEventSender' :: IOState -> StdInOut -> IO IOState -stdInEventSender' stdInState StdInReceiveContents = doStdInGet stdInState linedGetContents StdInReceivedContents - where - linedGetContents = (getContents >>= (\strContents -> return $ lines strContents)) +stdInEventSender' stdInState StdInReceiveContents + = doStdInGet stdInState linedGetContents StdInReceivedContents + where + linedGetContents = (getContents >>= (\strContents -> return $ lines strContents)) stdInEventSender' stdInState StdInReceiveLine = doStdInGet stdInState getLine StdInReceivedLine stdInEventSender' stdInState StdInReceiveChar = doStdInGet stdInState getChar StdInReceivedChar
src/Eventloop/Module/StdOut/StdOut.hs view
@@ -1,24 +1,27 @@ module Eventloop.Module.StdOut.StdOut - ( defaultStdOutModuleConfiguration + ( setupStdOutModuleConfiguration , stdOutModuleIdentifier , stdOutEventSender ) where import System.IO -import Eventloop.Types.EventTypes +import Control.Concurrent.SafePrint + import Eventloop.Module.StdOut.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System -defaultStdOutModuleConfiguration :: EventloopModuleConfiguration -defaultStdOutModuleConfiguration = ( EventloopModuleConfiguration +setupStdOutModuleConfiguration :: EventloopSetupModuleConfiguration +setupStdOutModuleConfiguration = ( EventloopSetupModuleConfiguration stdOutModuleIdentifier - NoState Nothing Nothing Nothing Nothing - Nothing (Just stdOutEventSender) + Nothing ) stdOutModuleIdentifier :: EventloopModuleIdentifier @@ -27,6 +30,6 @@ stdOutEventSender :: EventSender stdOutEventSender sharedIO state (OutStdOut (StdOutMessage str)) = do - putStr str + safePrint (safePrintToken sharedIO) str hFlush stdout return (sharedIO, state)
src/Eventloop/Module/Timer/Timer.hs view
@@ -1,6 +1,5 @@ module Eventloop.Module.Timer.Timer - ( defaultTimerModuleConfiguration - , defaultTimerModuleIOState + ( setupTimerModuleConfiguration , timerModuleIdentifier , timerInitializer , timerEventRetriever @@ -14,31 +13,29 @@ import Data.Maybe import Data.List -import Eventloop.Types.EventTypes import Eventloop.Module.Timer.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System -defaultTimerModuleConfiguration :: EventloopModuleConfiguration -defaultTimerModuleConfiguration = ( EventloopModuleConfiguration +setupTimerModuleConfiguration :: EventloopSetupModuleConfiguration +setupTimerModuleConfiguration = ( EventloopSetupModuleConfiguration timerModuleIdentifier - defaultTimerModuleIOState (Just timerInitializer) (Just timerEventRetriever) Nothing Nothing - (Just timerTeardown) (Just timerEventSender) + (Just timerTeardown) ) -defaultTimerModuleIOState :: IOState -defaultTimerModuleIOState = TimerState [] [] undefined undefined - timerModuleIdentifier :: EventloopModuleIdentifier timerModuleIdentifier = "timer" timerInitializer :: Initializer -timerInitializer sharedIO _ = do +timerInitializer sharedIO = do incTickBuff <- newMVar [] incITickBuff <- newMVar [] return (sharedIO, TimerState [] [] incITickBuff incTickBuff) @@ -93,7 +90,7 @@ allStartedTimers = (startedTimers timerState) ++ (startedIntervalTimers timerState) allStartedIds = map fst allStartedTimers sequence_ (map (\id -> unregisterTimer id allStartedTimers) allStartedIds) - return (sharedIO, timerState {startedTimers = [], startedIntervalTimers = []}) + return (sharedIO) registerTimer :: [StartedTimer] -> IncomingTickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO [StartedTimer]
src/Eventloop/Module/Websocket/Canvas/Canvas.hs view
@@ -1,46 +1,54 @@-module Eventloop.Module.Websocket.Canvas.Canvas where +module Eventloop.Module.Websocket.Canvas.Canvas + ( setupCanvasModuleConfiguration + , canvasModuleIdentifier + , canvasInitializer + , canvasEventRetriever + , canvasEventSender + , canvasTeardown + ) where -import Control.Concurrent.MVar + import Control.Concurrent +import Control.Concurrent.MVar +import Control.Concurrent.Thread import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS -import Eventloop.Utility.Config -import Eventloop.Utility.Concurrent -import Eventloop.Types.EventTypes import Eventloop.Module.Websocket.Canvas.Types import Eventloop.Module.Websocket.Canvas.JSONEncoding - +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System +import Eventloop.Utility.Config import qualified Eventloop.Utility.Websockets as WS -defaultCanvasModuleConfiguration :: EventloopModuleConfiguration -defaultCanvasModuleConfiguration = ( EventloopModuleConfiguration + +setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration +setupCanvasModuleConfiguration = ( EventloopSetupModuleConfiguration canvasModuleIdentifier - defaultCanvasModuleIOState (Just canvasInitializer) (Just canvasEventRetriever) Nothing Nothing - (Just canvasTeardown) (Just canvasEventSender) + (Just canvasTeardown) ) -defaultCanvasModuleIOState :: IOState -defaultCanvasModuleIOState = CanvasState undefined undefined undefined undefined undefined undefined undefined undefined - + canvasModuleIdentifier :: EventloopModuleIdentifier canvasModuleIdentifier = "canvas" canvasInitializer :: Initializer -canvasInitializer sharedIO _ = do - (comRecvBuffer, clientSocket, clientConn, serverSock, unbufferedReaderThread) <- WS.setupWebsocketConnection ipAddress canvasPort - putStrLn "Canvas connection successfull!" - userRecvBuffer <- newMVar [] - sysRecvBuffer <- newEmptyMVar - routerThread <- fork (router comRecvBuffer userRecvBuffer sysRecvBuffer) - --TODO Add measuretext to sharedIO - return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientSocket clientConn serverSock unbufferedReaderThread routerThread) +canvasInitializer sharedIO + = do + (comRecvBuffer, clientSocket, clientConn, serverSock, unbufferedReaderThread) <- WS.setupWebsocketConnection ipAddress canvasPort + putStrLn "Canvas connection successfull!" + userRecvBuffer <- newMVar [] + sysRecvBuffer <- newEmptyMVar + routerThread <- forkThread (router comRecvBuffer userRecvBuffer sysRecvBuffer) + --TODO Add measuretext to sharedIO + return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientSocket clientConn serverSock unbufferedReaderThread routerThread) canvasEventRetriever :: EventRetriever @@ -62,11 +70,13 @@ canvasTeardown :: Teardown -canvasTeardown sharedIO canvasState = do - WS.closeWebsocketConnection (serverSocket canvasState) (clientSocket canvasState) (clientConnection canvasState) (unbufferedReaderThread canvasState) - terminateThread (routerThread canvasState) - join (routerThread canvasState) - return (sharedIO, defaultCanvasModuleIOState) +canvasTeardown sharedIO canvasState + = do + WS.closeWebsocketConnection (serverSocket canvasState) (clientSocket canvasState) (clientConnection canvasState) (unbufferedReaderThread canvasState) + terminateThread (routerThread canvasState) + joinThread (routerThread canvasState) + -- Todo teardown measureText websocket connection + return sharedIO sendRoutedMessageOut :: WS.Connection -> RoutedMessageOut -> IO ()
src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Eventloop.Module.Websocket.Keyboard.Keyboard - ( defaultKeyboardModuleConfiguration - , defaultKeyboardModuleIOState + ( setupKeyboardModuleConfiguration , keyboardModuleIdentifier , keyboardInitializer , keyboardEventRetriever @@ -11,30 +10,29 @@ import Data.Aeson import Data.Maybe import Control.Applicative +import Control.Concurrent.SafePrint import qualified Data.ByteString.Lazy.Char8 as BL -import Eventloop.Types.EventTypes +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System import Eventloop.Module.Websocket.Keyboard.Types import Eventloop.Utility.Config import qualified Eventloop.Utility.BufferedWebsockets as WS -defaultKeyboardModuleConfiguration :: EventloopModuleConfiguration -defaultKeyboardModuleConfiguration = ( EventloopModuleConfiguration +setupKeyboardModuleConfiguration :: EventloopSetupModuleConfiguration +setupKeyboardModuleConfiguration = ( EventloopSetupModuleConfiguration keyboardModuleIdentifier - defaultKeyboardModuleIOState (Just keyboardInitializer) (Just keyboardEventRetriever) Nothing Nothing - (Just keyboardTeardown) Nothing + (Just keyboardTeardown) ) - -defaultKeyboardModuleIOState :: IOState -defaultKeyboardModuleIOState = KeyboardState undefined undefined undefined undefined undefined - + keyboardModuleIdentifier :: EventloopModuleIdentifier keyboardModuleIdentifier = "keyboard" @@ -44,10 +42,11 @@ keyboardInitializer :: Initializer -keyboardInitializer sharedIO _ = do - (recvBuffer, clientSocket, clientConn, serverSock, bufferedReaderThread) <- WS.setupWebsocketConnection ipAddress keyboardPort - putStrLn "Keyboard connection successfull" - return (sharedIO, KeyboardState recvBuffer clientSocket clientConn serverSock bufferedReaderThread) +keyboardInitializer 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) keyboardEventRetriever :: EventRetriever @@ -61,10 +60,10 @@ keyboardTeardown :: Teardown -keyboardTeardown sharedIO ks = - do +keyboardTeardown sharedIO ks + = do WS.closeWebsocketConnection (serverSocket ks) (clientSocket ks) (clientConnection ks) (bufferedReaderThread ks) - return (sharedIO, defaultKeyboardModuleIOState) + return sharedIO
src/Eventloop/Module/Websocket/Mouse/Mouse.hs view
@@ -1,46 +1,44 @@ {-# LANGUAGE OverloadedStrings #-} module Eventloop.Module.Websocket.Mouse.Mouse - ( defaultMouseModuleConfiguration - , defaultMouseModuleIOState + ( setupMouseModuleConfiguration , mouseModuleIdentifier , mouseInitializer , mouseEventRetriever , mouseTeardown ) where +import Control.Applicative +import Control.Monad +import Control.Concurrent.SafePrint import Data.Aeson import Data.Aeson.Types -import Control.Monad -import Control.Applicative -import Data.Maybe import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Maybe -import qualified Eventloop.Utility.BufferedWebsockets as WS -import Eventloop.Types.EventTypes -import Eventloop.Types.Common 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 - -defaultMouseModuleConfiguration :: EventloopModuleConfiguration -defaultMouseModuleConfiguration = ( EventloopModuleConfiguration +setupMouseModuleConfiguration :: EventloopSetupModuleConfiguration +setupMouseModuleConfiguration = ( EventloopSetupModuleConfiguration mouseModuleIdentifier - defaultMouseModuleIOState (Just mouseInitializer) (Just mouseEventRetriever) Nothing Nothing - (Just mouseTeardown) Nothing + (Just mouseTeardown) ) -defaultMouseModuleIOState :: IOState -defaultMouseModuleIOState = MouseState undefined undefined undefined undefined undefined mouseModuleIdentifier :: EventloopModuleIdentifier mouseModuleIdentifier = "mouse" + instance FromJSON MouseIn where parseJSON vO@(Object v) = do @@ -88,10 +86,11 @@ mouseInitializer :: Initializer -mouseInitializer sharedIO _ = do - (recvBuffer, clientSocket, clientConn, serverSock, bufferedReaderThread) <- WS.setupWebsocketConnection ipAddress mousePort - putStrLn "Mouse connection succesfull" - return (sharedIO, MouseState recvBuffer clientSocket clientConn serverSock bufferedReaderThread) +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 @@ -108,5 +107,5 @@ mouseTeardown sharedIO ms = do WS.closeWebsocketConnection (serverSocket ms) (clientSocket ms) (clientConnection ms) (bufferedReaderThread ms) - return (sharedIO, defaultMouseModuleIOState) + return sharedIO
+ src/Eventloop/OutRouter.hs view
@@ -0,0 +1,19 @@+module Eventloop.OutRouter where + +import Eventloop.Types.Events +import Eventloop.Types.System + +import Eventloop.Module.File +import Eventloop.Module.Timer +import Eventloop.Module.StdIn +import Eventloop.Module.StdOut +import Eventloop.Module.Websocket.Canvas + +routeOutEvent :: OutEventRouter +routeOutEvent out = case out of + (OutFile _) -> fileModuleIdentifier + (OutTimer _) -> timerModuleIdentifier + (OutStdOut _) -> stdOutModuleIdentifier + (OutStdIn _) -> stdInModuleIdentifier + (OutCanvas _) -> canvasModuleIdentifier + _ -> error ("Could not find route for out event: " ++ show out)
− src/Eventloop/RouteEvent.hs
@@ -1,18 +0,0 @@-module Eventloop.RouteEvent where - -import Eventloop.Types.EventTypes - -import Eventloop.Module.File -import Eventloop.Module.Timer -import Eventloop.Module.StdIn -import Eventloop.Module.StdOut -import Eventloop.Module.Websocket.Canvas - -routeOutEvent :: OutEventRouter -routeOutEvent out = case out of - (OutFile _) -> fileModuleIdentifier - (OutTimer _) -> timerModuleIdentifier - (OutStdOut _) -> stdOutModuleIdentifier - (OutStdIn _) -> stdInModuleIdentifier - (OutCanvas _) -> canvasModuleIdentifier - _ -> error ("Could not find route for out event: " ++ show out)
+ src/Eventloop/System/DisplayExceptionThread.hs view
@@ -0,0 +1,21 @@+module Eventloop.System.DisplayExceptionThread + ( startDisplayingExceptions + ) where + +import Control.Concurrent.ExceptionCollection + +import Eventloop.Types.Exception +import Eventloop.Types.System + + +startDisplayingExceptions :: EventloopSystemConfiguration progstateT + -> IO () +startDisplayingExceptions systemConfig + = do + exceptions_ <- collectExceptions (exceptions systemConfig) + mapM_ displayException exceptions_ + + +displayException :: EventloopException + -> IO () +displayException eventloopException = putStrLn (show eventloopException)
+ src/Eventloop/System/EventloopThread.hs view
@@ -0,0 +1,79 @@+module Eventloop.System.EventloopThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent.ExceptionUtility +import Control.Concurrent.MVar +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Data.Maybe + +import Eventloop.System.Processing +import Eventloop.Types.Common +import Eventloop.Types.Exception +import Eventloop.Types.Events +import Eventloop.Types.System + +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 + where + eventloopConfig_ = eventloopConfig systemConfig + eventloop = eventloopFunc eventloopConfig_ + progstateM_ = progstateM eventloopConfig_ + inEventQueue_ = inEventQueue eventloopConfig_ + outEventQueue_ = outEventQueue eventloopConfig_ + moduleConfigurations_ = moduleConfigs systemConfig + modulePreprocessors = findProcessors moduleConfigurations_ preprocessorM + modulePostprocessors = findProcessors moduleConfigurations_ postprocessorM + + +findProcessors :: [EventloopModuleConfiguration] + -> (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -- Pre-/Postprocessor function + -> [(EventloopModuleIdentifier, MVar IOState, (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [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 + + +eventloopSteps :: (progstateT -> In -> (progstateT, [Out])) {-| eventloop function -} + -> MVar progstateT + -> [In] + -> IO [Out] +eventloopSteps eventloop progstateM inEvents + = sequencedSteps >>= (return.concat) + where + inEventSteps = map (eventloopStep eventloop progstateM) inEvents + sequencedSteps = sequence inEventSteps + + +eventloopStep :: (progstateT -> In -> (progstateT, [Out])) {-| eventloop function -} + -> MVar 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
+ src/Eventloop/System/InitializationThread.hs view
@@ -0,0 +1,36 @@+module Eventloop.System.InitializationThread + ( startInitializing + ) where + +import Control.Exception +import Control.Concurrent.MVar + +import Eventloop.System.ThreadActions +import Eventloop.Types.Exception +import Eventloop.Types.System + + +startInitializing :: EventloopSystemConfiguration progstateT + -> IO () +startInitializing systemConfig + = mapM_ (initializeModule sharedIOStateM_) moduleConfigs_ + where + sharedIOStateM_ = sharedIOStateM systemConfig + moduleConfigs_ = moduleConfigs systemConfig + + +initializeModule :: MVar SharedIOState + -> EventloopModuleConfiguration + -> IO () +initializeModule sharedIOStateM_ moduleConfig + = case (initializerM moduleConfig) of + Nothing -> return () + (Just initializer) -> do + initializeIOState sharedIOStateM_ iostateM_ + ( \exception -> + throwIO (InitializationException moduleId_ exception) + ) + initializer + where + moduleId_ = moduleId moduleConfig + iostateM_ = iostateM moduleConfig
+ src/Eventloop/System/OutRouterThread.hs view
@@ -0,0 +1,68 @@+module Eventloop.System.OutRouterThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.OutRouter +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Types.System + +{- | Grab an outEvent from the outEventQueue and route it to the correct module sender if any. +If there isn't one, throw a NoOutRouteException. The router will continue until it: +- Comes across a Stop outEvent: Raises a RequestShutdownException +- Raises an exception +- Receives an exception (Only possibility is ShutdownException) +In all cases, a Stop outEvent is sent to all module senders. +-} +startOutRouting :: EventloopSystemConfiguration progstateT + -> IO () +startOutRouting systemConfig + = catch (forever $ do + outEvent <- takeFromBlockingConcurrentQueue outEventQueue_ + case outEvent of + Stop -> throwIO RequestShutdownException + _ -> outRouteOne moduleIdsSenderQueues outEvent + ) + (\exception -> do + outRouteBroadcastStop moduleIdsSenderQueues + throwIO (exception :: SomeException) + ) + where + moduleIdsSenderQueues = outRoutes (moduleConfigs systemConfig) + outEventQueue_ = outEventQueue (eventloopConfig systemConfig) + + +outRoutes :: [EventloopModuleConfiguration] -> [(EventloopModuleIdentifier, SenderEventQueue)] +outRoutes [] = [] +outRoutes (moduleConfig:mcs) = case (senderConfigM moduleConfig) of + Nothing -> outRoutes mcs + (Just moduleSenderConfig) -> (moduleId moduleConfig, senderEventQueue moduleSenderConfig):(outRoutes mcs) + + +outRouteOne :: [(EventloopModuleIdentifier, SenderEventQueue)] + -> Out + -> IO () +outRouteOne targetIdsSenderQueues outEvent + = case targetSenderQueueM of + Nothing -> + throwIO (NoOutRouteException outEvent) + (Just targetSenderQueue) -> + putInBlockingConcurrentQueue targetSenderQueue outEvent + where + targetModuleIdentifier = routeOutEvent outEvent + targetSenderQueueM = lookup targetModuleIdentifier targetIdsSenderQueues + + +outRouteBroadcastStop :: [(EventloopModuleIdentifier, SenderEventQueue)] + -> IO () +outRouteBroadcastStop [] + = return () +outRouteBroadcastStop targetIdsSenderQueues + = mapM_ broadcastAction (map snd targetIdsSenderQueues) + where + broadcastAction targetSenderQueue = + putInBlockingConcurrentQueue targetSenderQueue Stop
+ src/Eventloop/System/Processing.hs view
@@ -0,0 +1,80 @@+module Eventloop.System.Processing where + +import Control.Exception +import Control.Concurrent.ExceptionUtility +import Control.Concurrent.MVar + +import Eventloop.Types.Common +import Eventloop.Types.Exception +import Eventloop.Types.Events +import Eventloop.Types.System + +{- + To handle the pre-/postprocessing of in/out events + Per module is needed: (moduleIdentifier, iostateM, processFunc) + Only modules with the appropriate processFunc are included if they exist +-} + +processEventWithModule :: ProcessingDescription + -> MVar SharedIOState + -> ( EventloopModuleIdentifier + , MVar IOState + , (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [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') + ) + ) + ( \exception -> + throwIO (ProcessingException processingDescription moduleId exception) + ) + >>= return.snd + + +processEventsWithModules :: ProcessingDescription + -> MVar SharedIOState + -> [( EventloopModuleIdentifier + , MVar IOState + , (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])) + )] + -> [event] + -> IO [event] +processEventsWithModules _ _ _ [] + = return [] +processEventsWithModules _ _ [] events + = return events +processEventsWithModules processingDescription sharedIOM (moduleProcessor:mps) (event:events) + = do + generatedEvents <- processEventWithModule processingDescription sharedIOM moduleProcessor event + processedEvents <- processEventsWithModules processingDescription sharedIOM mps generatedEvents + restProcessedEvents <- processEventsWithModules processingDescription sharedIOM (moduleProcessor:mps) events + return (processedEvents ++ restProcessedEvents) + + +processEvents :: ProcessingDescription + -> EventloopSystemConfiguration progstateT + -> [( EventloopModuleIdentifier + , MVar IOState + , (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event])) + )] + -> [event] + -> IO [event] +processEvents processingDescription systemConfig moduleProcessors events + = processEventsWithModules processingDescription sharedIOM moduleProcessors events + where + sharedIOM = sharedIOStateM systemConfig
+ src/Eventloop/System/RetrieverThread.hs view
@@ -0,0 +1,44 @@+module Eventloop.System.RetrieverThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.System.ThreadActions +import Eventloop.Types.Common +import Eventloop.Types.Exception +import Eventloop.Types.System + +startRetrieving :: EventloopSystemConfiguration progstateT + -> (EventloopModuleConfiguration, EventRetriever) + -> IO () +startRetrieving systemConfig (moduleConfig, retriever) + = forever (retrieveOne moduleId_ sharedIOStateM_ iostateM_ retriever inEventQueue_) + where + moduleId_ = moduleId moduleConfig + eventloopConfiguration = eventloopConfig systemConfig + sharedIOStateM_ = sharedIOStateM systemConfig + inEventQueue_ = inEventQueue eventloopConfiguration + iostateM_ = iostateM moduleConfig + + +retrieveOne :: EventloopModuleIdentifier -> + MVar SharedIOState -> + MVar 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') + )
+ src/Eventloop/System/SenderThread.hs view
@@ -0,0 +1,47 @@+module Eventloop.System.SenderThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.System.ThreadActions +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Types.System + +startSending :: EventloopSystemConfiguration progstateT + -> (EventloopModuleConfiguration, EventloopModuleSenderConfiguration) + -> IO () +startSending systemConfig (moduleConfig, moduleSenderConfig) + = forever $ do + outEvent <- takeFromBlockingConcurrentQueue senderEventQueue_ + case outEvent of + Stop -> throwIO RequestShutdownException + _ -> sendOne moduleId_ sharedIOStateM_ iostateM_ sender_ outEvent + where + moduleId_ = moduleId moduleConfig + sharedIOStateM_ = sharedIOStateM systemConfig + iostateM_ = iostateM moduleConfig + sender_ = sender moduleSenderConfig + senderEventQueue_ = senderEventQueue moduleSenderConfig + + +sendOne :: EventloopModuleIdentifier + -> MVar SharedIOState + -> MVar 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 + )
+ src/Eventloop/System/Setup.hs view
@@ -0,0 +1,87 @@+module Eventloop.System.Setup + ( setupEventloopSystemConfig + ) where + +import Control.Concurrent +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.MVar +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.DefaultConfiguration +import Eventloop.Types.System + + +setupEventloopSystemConfig :: EventloopSetupConfiguration progstateT + -> IO (EventloopSystemConfiguration progstateT) +setupEventloopSystemConfig setupConfig + = do + eventloopConfig_ <- setupEventloopConfiguration setupConfig + moduleConfigurations_ <- mapM setupEventloopModuleConfig (setupModuleConfigurations setupConfig) + sharedIOState_ <- setupSharedIOState + sharedIOStateM_ <- newMVar sharedIOState_ + systemThreadId_ <- myThreadId + retrieverThreadsM_ <- newMVar [] + outRouterThreadM_ <- newEmptyMVar + senderThreadsM_ <- newMVar [] + exceptionCollection <- createExceptionCollection + isStoppingM_ <- newMVar False + + return ( EventloopSystemConfiguration + eventloopConfig_ + moduleConfigurations_ + sharedIOStateM_ + systemThreadId_ + retrieverThreadsM_ + outRouterThreadM_ + senderThreadsM_ + exceptionCollection + isStoppingM_ + ) + + +setupEventloopConfiguration :: EventloopSetupConfiguration progstateT + -> IO (EventloopConfiguration progstateT) +setupEventloopConfiguration setupConfig + = do + progstateM_ <- newMVar (beginProgstate setupConfig) + inEventQueue_ <- createBlockingConcurrentQueue + outEventQueue_ <- createBlockingConcurrentQueue + + return ( EventloopConfiguration + progstateM_ + (eventloopF setupConfig) + inEventQueue_ + outEventQueue_ + ) + + +setupEventloopModuleConfig :: EventloopSetupModuleConfiguration + -> IO EventloopModuleConfiguration +setupEventloopModuleConfig setupModuleConfig + = do + iostateM <- newMVar NoState + senderConfig <- setupEventloopModuleSenderConfiguration (eventSenderF setupModuleConfig) + + return ( EventloopModuleConfiguration + (moduleIdentifier setupModuleConfig) + iostateM + (initializerF setupModuleConfig) + (eventRetrieverF setupModuleConfig) + (preprocessorF setupModuleConfig) + (postprocessorF setupModuleConfig) + senderConfig + (teardownF setupModuleConfig) + ) + where + moduleId_ = moduleIdentifier setupModuleConfig + + + +setupEventloopModuleSenderConfiguration :: Maybe EventSender + -> IO (Maybe EventloopModuleSenderConfiguration) +setupEventloopModuleSenderConfiguration Nothing = return Nothing +setupEventloopModuleSenderConfiguration (Just eventSender_) + = do + senderEventQueue_ <- createBlockingConcurrentQueue + + return (Just (EventloopModuleSenderConfiguration eventSender_ senderEventQueue_))
+ src/Eventloop/System/TeardownThread.hs view
@@ -0,0 +1,36 @@+module Eventloop.System.TeardownThread + ( startTeardowning + ) where + +import Control.Exception +import Control.Concurrent.MVar + +import Eventloop.System.ThreadActions +import Eventloop.Types.Exception +import Eventloop.Types.System + + +startTeardowning :: EventloopSystemConfiguration progstateT + -> IO () +startTeardowning systemConfig + = mapM_ (teardownModule sharedIOStateM_) moduleConfigs_ + where + sharedIOStateM_ = sharedIOStateM systemConfig + moduleConfigs_ = moduleConfigs systemConfig + + +teardownModule :: MVar SharedIOState + -> EventloopModuleConfiguration + -> IO () +teardownModule sharedIOStateM_ moduleConfig + = case (teardownM moduleConfig) of + Nothing -> return () + (Just teardown) -> + teardownIOState sharedIOStateM_ iostateM_ + ( \exception -> + throwIO (TeardownException moduleId_ exception) + ) + teardown + where + moduleId_ = moduleId moduleConfig + iostateM_ = iostateM moduleConfig
+ src/Eventloop/System/ThreadActions.hs view
@@ -0,0 +1,86 @@+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 + )
src/Eventloop/Types/Common.hs view
@@ -1,4 +1,7 @@ module Eventloop.Types.Common where +type EventloopModuleIdentifier = [Char] +type ProcessingDescription = [Char] + type NamedId = [Char] type NumericId = Int
− src/Eventloop/Types/EventTypes.hs
@@ -1,121 +0,0 @@-module Eventloop.Types.EventTypes where - -import System.IO -import Data.Maybe -import Control.Concurrent - -import qualified Eventloop.Utility.Websockets as WS -import qualified Eventloop.Utility.BufferedWebsockets as BWS -import Eventloop.Utility.Concurrent - -import Eventloop.Module.Websocket.Keyboard.Types -import Eventloop.Module.Websocket.Mouse.Types -import Eventloop.Module.Websocket.Canvas.Types -import Eventloop.Module.DrawTrees.Types -import Eventloop.Module.BasicShapes.Types -import Eventloop.Module.File.Types -import Eventloop.Module.StdIn.Types -import Eventloop.Module.StdOut.Types -import Eventloop.Module.Timer.Types -import Eventloop.Module.Graphs.Types - - - --- General Types -type EventloopModuleIdentifier = [Char] -type Initializer = SharedIOState -> IOState -> 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, IOState) - -type OutEventRouter = Out -> EventloopModuleIdentifier - - -data EventloopModuleConfiguration = EventloopModuleConfiguration { moduleIdentifier :: EventloopModuleIdentifier - , iostate :: IOState - , initializer :: Maybe Initializer - , eventRetriever :: Maybe EventRetriever - , preprocessor :: Maybe PreProcessor - , postprocessor :: Maybe PostProcessor - , teardown :: Maybe Teardown - , eventSender :: Maybe EventSender - } - -data EventloopConfiguration progstateT = EventloopConfiguration { progState :: progstateT - , eventloopFunc :: progstateT -> In -> (progstateT, [Out]) - , outRouter :: OutEventRouter - , sharedIOState :: SharedIOState - , moduleConfigurations :: [EventloopModuleConfiguration] - } - -data In = Start - | InKeyboard Keyboard - | InMouse MouseIn - | InFile FileIn - | InTimer TimerIn - | InStdIn StdInIn - | InCanvas CanvasIn - | InGraphs GraphsIn - deriving (Eq, Show) - - -data Out = OutFile FileOut - | OutTimer TimerOut - | OutStdOut StdOutOut - | OutStdIn StdInOut - | OutCanvas CanvasOut - | OutBasicShapes BasicShapesOut - | OutDrawTrees DrawTreesOut - | OutGraphs GraphsOut - | Stop - deriving (Eq, Show) - - --- Shared IO State -data SharedIOState = SharedIOState { measureText :: CanvasText -> IO ScreenDimensions - } - --- 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] - , startedTimers :: [StartedTimer] - , incomingIntervalTickBuffer :: IncomingTickBuffer - , incomingTickBuffer :: IncomingTickBuffer - } - | FileState { newFileInEvents :: [FileIn] - , opened :: [OpenFile] - } - | NoState - - --- API module types -type APIName = [Char] -type Parameter = [Char] ---type Value = [Char] ---type Parameters =[(Parameter, Value)] - -
+ src/Eventloop/Types/Events.hs view
@@ -0,0 +1,35 @@+module Eventloop.Types.Events where + +import Eventloop.Module.Websocket.Keyboard.Types +import Eventloop.Module.Websocket.Mouse.Types +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.DrawTrees.Types +import Eventloop.Module.BasicShapes.Types +import Eventloop.Module.File.Types +import Eventloop.Module.StdIn.Types +import Eventloop.Module.StdOut.Types +import Eventloop.Module.Timer.Types +import Eventloop.Module.Graphs.Types + + +data In = Start + | InKeyboard Keyboard + | InMouse MouseIn + | InFile FileIn + | InTimer TimerIn + | InStdIn StdInIn + | InCanvas CanvasIn + | InGraphs GraphsIn + deriving (Eq, Show) + + +data Out = OutFile FileOut + | OutTimer TimerOut + | OutStdOut StdOutOut + | OutStdIn StdInOut + | OutCanvas CanvasOut + | OutBasicShapes BasicShapesOut + | OutDrawTrees DrawTreesOut + | OutGraphs GraphsOut + | Stop + deriving (Eq, Show)
+ src/Eventloop/Types/Exception.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable #-} + +module Eventloop.Types.Exception where + + +import Control.Exception +import Data.Typeable + +import Eventloop.Types.Common +import Eventloop.Types.Events + + +data EventloopException = ShuttingDownException + | RequestShutdownException + | NoOutRouteException Out + | InitializationException EventloopModuleIdentifier SomeException + | RetrievingException EventloopModuleIdentifier SomeException + | ProcessingException ProcessingDescription EventloopModuleIdentifier SomeException + | EventloopException SomeException + | SendingException EventloopModuleIdentifier Out SomeException + | TeardownException EventloopModuleIdentifier SomeException + + deriving (Typeable) + +instance Exception EventloopException + + +instance Show EventloopException where + show ShuttingDownException = exceptionMessage "A shutting down exception has been logged. This should not happen. Please contact an administrator." + [] + show RequestShutdownException = "System is shutting down..." + + show (NoOutRouteException out) = exceptionMessage "Tried to route an Out even to a module but could not find an appropriate configured event sender." + [ ("Out event", show out) + ] + show (InitializationException moduleId e) = exceptionMessage "Tried to initialize a module but something happened." + [ ("Module", moduleId) + , ("Exception", show e) + ] + show (RetrievingException moduleId e) = exceptionMessage "Tried to retrieve an In event from a module but something happened. The retriever has been shutdown." + [ ("Module", moduleId) + , ("Exception", show e) + ] + show (ProcessingException processDesc moduleId e) = exceptionMessage "Tried to process an In\\Out event with a module but something happened." + [ ("Processor", processDesc) + , ("Module", moduleId) + , ("Exception", show e) + ] + show (EventloopException e) = exceptionMessage "An exception occurred in your eventloop program." + [ ("Exception", show e) + ] + show (SendingException moduleId out e) = exceptionMessage "Tried to send an Out event with a module but something happened." + [ ("Module", moduleId) + , ("Out event", show out) + , ("Exception", show e) + ] + show (TeardownException moduleId e) = exceptionMessage "Tried to teardown a module but something happened." + [ ("Module", moduleId) + , ("Exception", show e) + ] + +exceptionMessage :: String + -> [(String, String)] + -> String +exceptionMessage description fields + = "- Exc: " ++ description ++ "\n" ++ (concat fieldLines) + where + fieldLines = map (\(field, value) -> " " ++ field ++ ": " ++ value ++ "\n") fields
+ src/Eventloop/Types/System.hs view
@@ -0,0 +1,134 @@+module Eventloop.Types.System where + +import Control.Concurrent +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.MVar +import Control.Concurrent.Thread +import Control.Concurrent.SafePrint +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Data.Maybe + +import Eventloop.Module.Websocket.Keyboard.Types +import Eventloop.Module.Websocket.Mouse.Types +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.File.Types +import Eventloop.Module.StdIn.Types +import Eventloop.Module.StdOut.Types +import Eventloop.Module.Timer.Types + +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 + + +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 OutEventRouter = Out -> EventloopModuleIdentifier + +type InEventQueue = BlockingConcurrentQueue In +type OutEventQueue = BlockingConcurrentQueue Out +type SenderEventQueue = BlockingConcurrentQueue Out + +-- System Configurations +data EventloopModuleConfiguration + = EventloopModuleConfiguration { moduleId :: EventloopModuleIdentifier + , iostateM :: MVar IOState + , initializerM :: Maybe Initializer + , retrieverM :: Maybe EventRetriever + , preprocessorM :: Maybe PreProcessor + , postprocessorM :: Maybe PostProcessor + , senderConfigM :: Maybe EventloopModuleSenderConfiguration + , teardownM :: Maybe Teardown + } + + +data EventloopModuleSenderConfiguration + = EventloopModuleSenderConfiguration { sender :: EventSender + , senderEventQueue :: BlockingConcurrentQueue Out + } + + +data EventloopConfiguration progstateT + = EventloopConfiguration { progstateM :: MVar progstateT + , eventloopFunc :: progstateT -> In -> (progstateT, [Out]) + , inEventQueue :: InEventQueue + , outEventQueue :: OutEventQueue + } + + +data EventloopSystemConfiguration progstateT + = EventloopSystemConfiguration { eventloopConfig :: EventloopConfiguration progstateT + , moduleConfigs :: [EventloopModuleConfiguration] + , sharedIOStateM :: MVar SharedIOState + , systemThreadId :: ThreadId + , retrieverThreadsM :: MVar [Thread] + , outRouterThreadM :: MVar Thread + , senderThreadsM :: MVar [Thread] + , exceptions :: ExceptionCollection EventloopException + , isStoppingM :: MVar Bool + } + +-- Setup Configurations +data EventloopSetupConfiguration progstateT + = EventloopSetupConfiguration { beginProgstate :: progstateT + , eventloopF :: progstateT -> In -> (progstateT, [Out]) + , setupModuleConfigurations :: [EventloopSetupModuleConfiguration] + } + + +data EventloopSetupModuleConfiguration + = EventloopSetupModuleConfiguration { moduleIdentifier :: EventloopModuleIdentifier + , initializerF :: Maybe Initializer + , eventRetrieverF :: Maybe EventRetriever + , preprocessorF :: Maybe PreProcessor + , postprocessorF :: Maybe PostProcessor + , eventSenderF :: Maybe EventSender + , teardownF :: Maybe Teardown + } + + +-- Shared IO State +data SharedIOState = SharedIOState { safePrintToken :: SafePrintToken + , measureText :: CanvasText -> IO ScreenDimensions + } + +-- 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] + , startedTimers :: [StartedTimer] + , incomingIntervalTickBuffer :: IncomingTickBuffer + , incomingTickBuffer :: IncomingTickBuffer + } + | FileState { newFileInEvents :: [FileIn] + , opened :: [OpenFile] + } + | NoState
src/Eventloop/Utility/BufferedWebsockets.hs view
@@ -12,7 +12,7 @@ import Control.Concurrent import Control.Exception -import Eventloop.Utility.Concurrent +import Control.Concurrent.Thread import Eventloop.Utility.Websockets hiding ( ReceiveBuffer , setupWebsocketConnection @@ -37,7 +37,7 @@ spawnBufferedReader :: BufferedReceiveBuffer -> Connection -> ClientSocket -> IO BufferedReaderThread spawnBufferedReader recvBuffer conn clientSocket - = fork (handle (handleCloseRequestException clientSocket) $ bufferedReadIntoBuffer recvBuffer conn) + = forkThread (handle (handleCloseRequestException clientSocket) $ bufferedReadIntoBuffer recvBuffer conn) bufferedReadIntoBuffer :: BufferedReceiveBuffer -> Connection -> IO ()
− src/Eventloop/Utility/Concurrent.hs
@@ -1,44 +0,0 @@-module Eventloop.Utility.Concurrent - ( Thread - , fork - , join - , terminateThread - ) where - -import Control.Exception -import Control.Concurrent -import Control.Concurrent.MVar - -type WaitOn = MVar () -data Thread = Thread ThreadId WaitOn - - -fork :: IO () -> IO Thread -fork action - = do - waitOn <- newEmptyMVar - tid <- forkFinally action (setTerminated waitOn) - return (Thread tid waitOn) - - -setTerminated :: WaitOn -> (Either SomeException a) -> IO () -setTerminated waitOn (Right _) - = putMVar waitOn () - -setTerminated waitOn (Left someException) - = do - putMVar waitOn () - throw someException - - - -join :: Thread -> IO () -join (Thread threadId waitOn) - = do - takeMVar waitOn - return () - -terminateThread :: Thread -> IO () -terminateThread (Thread tid _) - = do - killThread tid
src/Eventloop/Utility/Websockets.hs view
@@ -11,7 +11,7 @@ import Control.Exception import Data.ByteString.Lazy -import Eventloop.Utility.Concurrent +import Control.Concurrent.Thread type Host = [Char] type Port = Int @@ -54,7 +54,7 @@ spawnUnbufferedReader :: ReceiveBuffer -> Connection -> ClientSocket -> IO UnbufferedReaderThread spawnUnbufferedReader recvBuffer conn clientSocket - = fork (handle (handleCloseRequestException clientSocket) $ readIntoBuffer recvBuffer conn) + = forkThread (handle (handleCloseRequestException clientSocket) $ readIntoBuffer recvBuffer conn) readIntoBuffer :: ReceiveBuffer -> Connection -> IO () @@ -95,9 +95,7 @@ takeMessage :: ReceiveBuffer -> IO Message -takeMessage recvBuffer = do - message <- takeMVar recvBuffer - return message +takeMessage recvBuffer = takeMVar recvBuffer writeMessage :: Connection -> Message -> IO () @@ -128,6 +126,6 @@ ) ( sendClose clientConnection (T.pack "Shutting down..") ) - join readerThread + joinThread readerThread