eventloop 0.4.0.0 → 0.4.1.0

raw patch · 9 files changed

+388/−194 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• eventloop.cabal +2/−1
• src/Eventloop/EventloopCore.hs +223/−120
• src/Eventloop/Module/Websocket/Canvas/Canvas.hs +9/−7
• src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs +7/−6
• src/Eventloop/Module/Websocket/Mouse/Mouse.hs +7/−6
• src/Eventloop/Types/EventTypes.hs +16/−9
• src/Eventloop/Utility/BufferedWebsockets.hs +18/−14
• src/Eventloop/Utility/Concurrent.hs +44/−0
• src/Eventloop/Utility/Websockets.hs +62/−31

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.4.0.0
+version:             0.4.1.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),
@@ -54,6 +54,7 @@                        Eventloop.Utility.BufferedWebsockets,
                        Eventloop.Utility.Config,
                        Eventloop.Utility.Trees.LayoutTree,
+                       Eventloop.Utility.Concurrent,
                        Eventloop.Module.Websocket.Canvas.Canvas,
                        Eventloop.Module.Websocket.Canvas.JSONEncoding,
                        Eventloop.Module.Websocket.Canvas.Opcode,

@@ -7,59 +7,110 @@ import Data.Maybe
 import Control.Exception
 
-                                                                                        
+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@(EventloopConfiguration { moduleConfigurations = moduleConfigs
-                                                      , sharedIOState = sharedIO
-                                                      }) = do
-                                                               (sharedIO', moduleConfigs') <- withIOStateModules sharedIO initializer moduleConfigs
-                                                               let
-                                                                eventloopConfig' = eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}
-                                                                emergencyTeardown = withIOStateModules sharedIO' teardown moduleConfigs'
-                                                               (flip onException) emergencyTeardown $ do
-                                                                                                           eventloopConfig'' <- startMainloopWithStart eventloopConfig'
-                                                                                                           let
-                                                                                                            moduleConfigs'' = moduleConfigurations eventloopConfig''
-                                                                                                            sharedIO''      = sharedIOState eventloopConfig''
-                                                                                                           (sharedIO''', moduleStates''') <- withIOStateModules sharedIO'' teardown moduleConfigs''
-                                                                                                           return ()
+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..."
 
-withIOStateModules :: SharedIOState -> 
-                      (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) ->
-                      [EventloopModuleConfiguration] ->
-                      IO (SharedIOState, [EventloopModuleConfiguration])
-withIOStateModules sharedIO _ [] = return (sharedIO, [])
-withIOStateModules sharedIO getFunc (mc:mcs) = do
-                                                (sharedIO', mc') <- withIOStateModule sharedIO getFunc mc
-                                                (sharedIO'', mcs') <- withIOStateModules sharedIO' getFunc mcs
-                                                return (sharedIO'', mc':mcs')
-                                                               
-withIOStateModule :: SharedIOState -> 
-                    (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) -> 
-                    EventloopModuleConfiguration ->
-                    IO (SharedIOState, EventloopModuleConfiguration)
-withIOStateModule sharedIO getFunc mc = case (getFunc mc) of
-                                            Nothing     -> return (sharedIO, mc)
-                                            Just (func) -> do
-                                                            (sharedIO', iostate') <- func sharedIO (iostate mc)
-                                                            return (sharedIO', mc {iostate=iostate'})
+
+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]))
+startMainloopWithStart ec = handleMainloopUsingSource (return (ec, [Start], False))
                                                                                         
 
-handleMainloopUsingSource :: IO (EventloopConfiguration progstateT, [In]) -> IO (EventloopConfiguration progstateT)
+handleMainloopUsingSource :: IO (EventloopConfiguration progstateT, [In], HasToStop) -> IO (EventloopConfiguration progstateT)
 handleMainloopUsingSource source = do
-                                    (ec', inEvents) <- source
-                                    (ec'', inEvents') <- processEvents ec' preprocessor inEvents -- Do preprocess step
-                                    (ec'', stopFound) <- foldl (>>=) (return (ec'', False)) (map handleSingleInEvent inEvents') -- Handle each inEvent
-                                    if stopFound
-                                        then (return ec'')
-                                        else (handleMainloopUsingSource (receiveEvents ec''))
+                                    (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])
+receiveEvents :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, [In], HasToStop)
 receiveEvents eventloopConfig = do
                                     let
                                         (moduleConfig:mcs) = moduleConfigurations eventloopConfig
@@ -68,22 +119,52 @@                                         checkNextModule sio mc = receiveEvents (eventloopConfig {moduleConfigurations=(mcs++[mc]), sharedIOState=sio})
                                     case eventRetrieverM of
                                         Nothing -> checkNextModule sharedIO moduleConfig
-                                        Just er -> 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)
+                                        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, Bool) -> IO (EventloopConfiguration progstateT, Bool)
-handleSingleInEvent inEvent (ec, stopFound)  | stopFound = return (ec, stopFound)
-                                             | otherwise = do
-                                                            let
-                                                             (ec', outEvents) = doEventloop ec inEvent -- Do eventloop step
-                                                            (ec'', outEvents') <- processEvents ec' postprocessor outEvents -- Do postprocess step
-                                                            sendOutEvents ec'' outEvents' -- Do send outEvents step
+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])
@@ -93,35 +174,54 @@                         ec' = ec {progState = progState'}
  
 
-sendOutEvents :: EventloopConfiguration progstateT -> [Out] -> IO (EventloopConfiguration progstateT, Bool)
+sendOutEvents :: EventloopConfiguration progstateT -> [Out] -> IO (EventloopConfiguration progstateT, HasToStop)
 sendOutEvents ec [] = return (ec, False)
-sendOutEvents ec (Stop:outs) = return (ec, True)
-sendOutEvents ec (out:outs) = case sendModuleConfigM of
-                                Nothing -> error ("Could not send outEvent because module is not configured. Wanted to use module: " ++ (show moduleToRoute) ++ " Event: " ++ (show out))
-                                Just sendModuleConfig -> do
-                                                            let
-                                                                eventSenderFuncM = eventSender sendModuleConfig
-                                                                moduleIOState = iostate sendModuleConfig
-                                                            case eventSenderFuncM of
-                                                                    Nothing -> error ("Could not send outEvent because module eventsender is not configured. Using module: " ++ (show moduleToRoute) ++ " Event:  " ++ (show out))
-                                                                    Just eventSenderFunc -> do
-                                                                                                (sharedIO', moduleIOState') <- eventSenderFunc sharedIO moduleIOState out
-                                                                                                let
-                                                                                                    sendModuleConfig' = sendModuleConfig {iostate=moduleIOState'}
-                                                                                                    ec' = ec {moduleConfigurations=(replaceModuleConfiguration sendModuleConfig' moduleConfigs), sharedIOState=sharedIO'}
-                                                                                                sendOutEvents ec' outs
-                            where
-                                sharedIO = sharedIOState ec
-                                moduleToRoute = (outRouter ec) out
-                                moduleConfigs = moduleConfigurations ec
-                                sendModuleConfigM = findModuleConfiguration moduleToRoute moduleConfigs
-                                
+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 :: 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
@@ -131,41 +231,44 @@                                                                                                 (sharedIO', iostate', events) <- processFunc sharedIO (iostate eventloopModuleConfig) event
                                                                                                 return (sharedIO', eventloopModuleConfig {iostate=iostate'}, events)
 
-                                                                                        
-processEventsModules :: SharedIOState ->
-                        [EventloopModuleConfiguration] -> 
-                        (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -> -- Function from moduleconfig to pre-/postprocess function
-                        [event] -> 
-                        IO (SharedIOState, [EventloopModuleConfiguration], [event])
-processEventsModules sharedIO mcs _ []    = return (sharedIO, mcs, [])
-processEventsModules sharedIO [] _ events = return (sharedIO, [], events)
-processEventsModules sharedIO (moduleConfig:mcs) getFunc (event:events) = do
-                                                                    (sharedIO', moduleConfig', moreEvents) <- processEventModule sharedIO moduleConfig getFunc event
-                                                                    (sharedIO'', mcs', moreEvents') <- processEventsModules sharedIO' mcs getFunc moreEvents
-                                                                    (sharedIO''', mcs'', events') <- processEventsModules sharedIO'' (moduleConfig':mcs') getFunc events
-                                                                    return (sharedIO''', mcs'', moreEvents' ++ 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 :: EventloopConfiguration progstateT ->
-                (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -> -- Function from moduleconfig to pre-/postprocess function
-                [event] ->
-                IO (EventloopConfiguration progstateT, [event])
-processEvents eventloopConfig getFunc events = do
-                                                let
-                                                    moduleConfigs = moduleConfigurations eventloopConfig
-                                                    sharedIO = sharedIOState eventloopConfig
-                                                (sharedIO', moduleConfigs', events') <- processEventsModules sharedIO moduleConfigs getFunc events
-                                                return (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}, events')
-                                                
-
-findModuleConfiguration :: EventloopModuleIdentifier -> [EventloopModuleConfiguration] -> Maybe EventloopModuleConfiguration
-findModuleConfiguration _ [] = Nothing
-findModuleConfiguration id (mc:mcs) | id == moduleId = Just mc
-                                    | otherwise = findModuleConfiguration id mcs
-                                    where
-                                        moduleId = moduleIdentifier mc
-                                        
-replaceModuleConfiguration :: EventloopModuleConfiguration -> [EventloopModuleConfiguration] -> [EventloopModuleConfiguration]
-replaceModuleConfiguration _ [] = []
-replaceModuleConfiguration mc (mc':mcs) | moduleIdentifier mc == moduleIdentifier mc' = (mc:mcs)
-                                        | otherwise = (mc':(replaceModuleConfiguration mc mcs))+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)

@@ -6,6 +6,7 @@ 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
@@ -25,7 +26,7 @@                                       )
                                       
 defaultCanvasModuleIOState :: IOState
-defaultCanvasModuleIOState = CanvasState undefined undefined undefined undefined undefined undefined
+defaultCanvasModuleIOState = CanvasState undefined undefined undefined undefined undefined undefined undefined undefined
 
 canvasModuleIdentifier :: EventloopModuleIdentifier
 canvasModuleIdentifier = "canvas"
@@ -33,13 +34,13 @@ 
 canvasInitializer :: Initializer
 canvasInitializer sharedIO _ = do
-                                (comRecvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress  canvasPort
+                                (comRecvBuffer, clientSocket, clientConn, serverSock, unbufferedReaderThread) <- WS.setupWebsocketConnection ipAddress canvasPort
                                 putStrLn "Canvas connection successfull!"
                                 userRecvBuffer <- newMVar []
                                 sysRecvBuffer <- newEmptyMVar
-                                routerThreadId <- forkIO (router comRecvBuffer userRecvBuffer sysRecvBuffer)
+                                routerThread <- fork (router comRecvBuffer userRecvBuffer sysRecvBuffer)
                                 --TODO Add measuretext to sharedIO
-                                return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientConn serverSock routerThreadId)
+                                return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientSocket clientConn serverSock unbufferedReaderThread routerThread)
 
 
 canvasEventRetriever :: EventRetriever
@@ -62,9 +63,10 @@                                     
 canvasTeardown :: Teardown
 canvasTeardown sharedIO canvasState = do
-                                        WS.closeWebsocketConnection (serverSocket canvasState) (clientConnection canvasState)
-                                        killThread (routerThreadId canvasState)
-                                        return (sharedIO, canvasState)
+                                        WS.closeWebsocketConnection (serverSocket canvasState) (clientSocket canvasState) (clientConnection canvasState) (unbufferedReaderThread canvasState)
+                                        terminateThread (routerThread canvasState)
+                                        join (routerThread canvasState)
+                                        return (sharedIO, defaultCanvasModuleIOState)
     
     
 sendRoutedMessageOut :: WS.Connection -> RoutedMessageOut -> IO ()

@@ -33,7 +33,7 @@ 
 
 defaultKeyboardModuleIOState :: IOState
-defaultKeyboardModuleIOState = KeyboardState undefined undefined undefined
+defaultKeyboardModuleIOState = KeyboardState undefined undefined undefined undefined undefined
 
 keyboardModuleIdentifier :: EventloopModuleIdentifier
 keyboardModuleIdentifier = "keyboard"
@@ -45,9 +45,9 @@     
 keyboardInitializer :: Initializer
 keyboardInitializer sharedIO _ = do
-                                    (recvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress  keyboardPort
+                                    (recvBuffer, clientSocket, clientConn, serverSock, bufferedReaderThread) <- WS.setupWebsocketConnection ipAddress  keyboardPort
                                     putStrLn "Keyboard connection successfull"
-                                    return (sharedIO, KeyboardState recvBuffer clientConn serverSock)
+                                    return (sharedIO, KeyboardState recvBuffer clientSocket clientConn serverSock bufferedReaderThread)
 
                             
 keyboardEventRetriever :: EventRetriever
@@ -61,9 +61,10 @@ 
 
 keyboardTeardown :: Teardown
-keyboardTeardown sharedIO ks@(KeyboardState _ clientConn serverSock) = do
-                                                                        WS.closeWebsocketConnection serverSock clientConn
-                                                                        return (sharedIO, ks)
+keyboardTeardown sharedIO ks = 
+    do
+        WS.closeWebsocketConnection (serverSocket ks) (clientSocket ks) (clientConnection ks) (bufferedReaderThread ks)
+        return (sharedIO, defaultKeyboardModuleIOState)
 
 
 

@@ -36,7 +36,7 @@                                   )
      
 defaultMouseModuleIOState :: IOState
-defaultMouseModuleIOState = MouseState undefined undefined undefined
+defaultMouseModuleIOState = MouseState undefined undefined undefined undefined undefined
 
 mouseModuleIdentifier :: EventloopModuleIdentifier
 mouseModuleIdentifier = "mouse"
@@ -89,9 +89,9 @@     
 mouseInitializer :: Initializer
 mouseInitializer sharedIO _ = do
-                                (recvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress  mousePort
+                                (recvBuffer, clientSocket, clientConn, serverSock, bufferedReaderThread) <- WS.setupWebsocketConnection ipAddress  mousePort
                                 putStrLn "Mouse connection succesfull"
-                                return (sharedIO, MouseState recvBuffer clientConn serverSock)
+                                return (sharedIO, MouseState recvBuffer clientSocket clientConn serverSock bufferedReaderThread)
 
 
 mouseEventRetriever :: EventRetriever
@@ -105,7 +105,8 @@ 
 
 mouseTeardown :: Teardown
-mouseTeardown sharedIO ms@(MouseState _ clientConn serverSock) = do
-                                                                    WS.closeWebsocketConnection serverSock clientConn
-                                                                    return (sharedIO, ms)
+mouseTeardown sharedIO ms
+    = do
+        WS.closeWebsocketConnection (serverSocket ms) (clientSocket ms) (clientConnection ms) (bufferedReaderThread ms)
+        return (sharedIO, defaultMouseModuleIOState)
 

@@ -6,6 +6,7 @@ 
 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
@@ -77,20 +78,26 @@                                    }
          
 -- Modules IO State
-data IOState = MouseState { receiveBuffer    :: BWS.BufferedReceiveBuffer
-                          , clientConnection :: BWS.Connection
-                          , serverSocket     :: BWS.Socket
+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.Socket
+                             , serverSocket     :: BWS.ServerSocket
+                             , bufferedReaderThread :: BWS.BufferedReaderThread
                              }
-             | CanvasState { commonReceiveBuffer :: WS.ReceiveBuffer
-                           , canvasUserReceiveBuffer :: CanvasUserReceiveBuffer
+             | CanvasState { commonReceiveBuffer       :: WS.ReceiveBuffer
+                           , canvasUserReceiveBuffer   :: CanvasUserReceiveBuffer
                            , canvasSystemReceiveBuffer :: CanvasSystemReceiveBuffer
-                           , clientConnection :: WS.Connection
-                           , serverSocket :: WS.Socket
-                           , routerThreadId :: ThreadId
+                           , clientSocket              :: WS.ClientSocket
+                           , clientConnection          :: WS.Connection
+                           , serverSocket              :: WS.ServerSocket
+                           , unbufferedReaderThread    :: WS.UnbufferedReaderThread
+                           , routerThread              :: Thread
                            }
              | StdInState { newStdInInEvents :: [StdInIn] 
                           }

@@ -11,6 +11,8 @@ import Control.Concurrent.MVar
 import Control.Concurrent
 import Control.Exception
+
+import Eventloop.Utility.Concurrent
     
 import Eventloop.Utility.Websockets hiding ( ReceiveBuffer
                                            , setupWebsocketConnection
@@ -21,29 +23,31 @@                                            )
 
 type BufferedReceiveBuffer = MVar [Message]
-
-setupWebsocketConnection :: Host -> Port -> IO (BufferedReceiveBuffer, Connection, S.Socket)
-setupWebsocketConnection host port = S.withSocketsDo $ do
-                                                        serverSocket <- createBindListenServerSocket host port
-                                                        clientConnection <- acceptFirstConnection serverSocket
-                                                        recvBuffer <- newMVar []
-                                                        spawnReader recvBuffer clientConnection
-                                                        return (recvBuffer, clientConnection, serverSocket)
+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)
                                                         
-spawnReader :: BufferedReceiveBuffer -> Connection -> IO ThreadId
-spawnReader recvBuffer conn = do
-                                forkIO (handle handleCloseRequestException $ readIntoBuffer recvBuffer conn)
                                                         
+spawnBufferedReader :: BufferedReceiveBuffer -> Connection -> ClientSocket -> IO BufferedReaderThread
+spawnBufferedReader recvBuffer conn clientSocket 
+    = fork (handle (handleCloseRequestException clientSocket) $ bufferedReadIntoBuffer recvBuffer conn)
                                                         
-readIntoBuffer :: BufferedReceiveBuffer -> Connection -> IO ()
-readIntoBuffer recvBuffer conn = do
+                                                        
+bufferedReadIntoBuffer :: BufferedReceiveBuffer -> Connection -> IO ()
+bufferedReadIntoBuffer recvBuffer conn = do
                                     textMessage <- receiveData conn
                                     let
                                         message = T.unpack textMessage
                                     messages <- takeMVar recvBuffer
                                     putMVar recvBuffer (messages ++ [message])
-                                    readIntoBuffer recvBuffer conn
+                                    bufferedReadIntoBuffer recvBuffer conn
                                     
                                     
 hasMessages :: BufferedReceiveBuffer -> IO Bool

@@ -0,0 +1,44 @@+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

@@ -1,6 +1,5 @@ module Eventloop.Utility.Websockets
     ( module Eventloop.Utility.Websockets
-    , S.Socket
     , Connection
     ) where
 
@@ -12,52 +11,50 @@ import Control.Exception
 import Data.ByteString.Lazy
 
+import Eventloop.Utility.Concurrent
+
 type Host = [Char]
 type Port = Int
 type Message = [Char]
 type ReceiveBuffer = MVar Message
 
+type ServerSocket = S.Socket
+type ClientSocket = S.Socket
+
+type ReaderThread = Thread
+type UnbufferedReaderThread = ReaderThread
+
                                     
-createBindListenServerSocket :: Host -> Port -> IO S.Socket
+createBindListenServerSocket :: Host -> Port -> IO ServerSocket
 createBindListenServerSocket host port = do
                                         host' <- S.inet_addr host
                                         socket <- S.socket S.AF_INET S.Stream S.defaultProtocol
-                                        --Prelude.putStrLn "created socket"
                                         S.setSocketOption socket S.ReuseAddr 1
-                                        --Prelude.putStrLn "set option"
                                         S.bindSocket socket (S.SockAddrInet (fromIntegral port) host')
-                                        --Prelude.putStrLn "binded it"
-                                        --threadDelay 500000
                                         S.listen socket 5
-                                        --threadDelay 500000
-                                        --Prelude.putStrLn "listening"
                                         return socket
 
                                         
-acceptFirstConnection :: S.Socket -> IO Connection
+acceptFirstConnection :: S.Socket -> IO (Connection, ClientSocket)
 acceptFirstConnection serverSocket = do
-                                        --Prelude.putStrLn "before accept"
                                         (clientSocket, clientAddr) <- S.accept serverSocket
-                                        --Prelude.putStrLn "accepted it!"
                                         pendingConnection <- makePendingConnection clientSocket defaultConnectionOptions
-                                        --Prelude.putStrLn "made pending connection"
                                         connection <- acceptRequest pendingConnection
-                                        --Prelude.putStrLn "accepted connection"
-                                        return connection
+                                        return (connection, clientSocket)
 
                                         
-setupWebsocketConnection :: Host -> Port -> IO (ReceiveBuffer, Connection, S.Socket)
+setupWebsocketConnection :: Host -> Port -> IO (ReceiveBuffer, ClientSocket, Connection, ServerSocket, UnbufferedReaderThread)
 setupWebsocketConnection host port = S.withSocketsDo $ do
                                                         serverSocket <- createBindListenServerSocket host port
-                                                        clientConnection <- acceptFirstConnection serverSocket
+                                                        (clientConnection, clientSocket) <- acceptFirstConnection serverSocket
                                                         recvBuffer <- newEmptyMVar
-                                                        spawnReader recvBuffer clientConnection
-                                                        return (recvBuffer, clientConnection, serverSocket)
+                                                        readerThread <- spawnUnbufferedReader recvBuffer clientConnection clientSocket
+                                                        return (recvBuffer, clientSocket, clientConnection, serverSocket, readerThread)
                                         
                                         
-spawnReader :: ReceiveBuffer -> Connection -> IO ThreadId
-spawnReader recvBuffer conn = do
-                                forkIO (handle handleCloseRequestException $ readIntoBuffer recvBuffer conn)
+spawnUnbufferedReader :: ReceiveBuffer -> Connection -> ClientSocket -> IO UnbufferedReaderThread
+spawnUnbufferedReader recvBuffer conn clientSocket 
+    = fork (handle (handleCloseRequestException clientSocket) $ readIntoBuffer recvBuffer conn)
                                 
                                 
 readIntoBuffer :: ReceiveBuffer -> Connection -> IO ()
@@ -67,12 +64,28 @@                                         message = T.unpack textMessage
                                     putMVar recvBuffer message
                                     readIntoBuffer recvBuffer conn
-                            
-handleCloseRequestException :: ConnectionException -> IO ()
-handleCloseRequestException (CloseRequest i reason) | i == 1000 = return ()
-                                                    | otherwise = Prelude.putStrLn ("Connection was closed but reason unknown: " ++ show i ++ show reason)
-handleCloseRequestException (ConnectionClosed)    = Prelude.putStrLn ("Connection was closed unexpectedly")
-handleCloseRequestException (ParseException text) = Prelude.putStrLn ("Parse exception on message: " ++ text)
+ 
+ 
+handleCloseRequestException :: ClientSocket -> ConnectionException -> IO ()
+handleCloseRequestException clientSocket (CloseRequest i reason) 
+    | i == 1000 = do
+                    Prelude.putStrLn "Client connected was closed elegantly."
+                    S.sClose clientSocket
+    | otherwise = do
+                    Prelude.putStrLn ("Connection was closed but reason unknown: " ++ show i ++ " " ++ show reason)
+                    S.sClose clientSocket
+    
+handleCloseRequestException clientSocket (ConnectionClosed)
+    = do
+        Prelude.putStrLn ("Connection was closed unexpectedly")
+        S.sClose clientSocket
+        throw ConnectionClosed
+    
+handleCloseRequestException clientSocket (ParseException text) 
+    = do
+        Prelude.putStrLn ("Parse exception on message: " ++ text)
+        S.sClose clientSocket
+        throw (ParseException text)
                             
                             
 hasMessage :: ReceiveBuffer -> IO Bool
@@ -95,8 +108,26 @@ writeBinaryMessage conn message = sendBinaryData conn message
 
 
-closeWebsocketConnection :: S.Socket -> Connection -> IO ()
-closeWebsocketConnection serverSocket clientConnection = do
-                                                            S.sClose serverSocket
-                                                            sendClose clientConnection (T.pack "Shutting down..")
+closeWebsocketConnection :: ServerSocket -> ClientSocket -> Connection -> ReaderThread -> IO ()
+closeWebsocketConnection serverSocket clientSocket clientConnection readerThread
+    = do
+        S.sClose serverSocket
+        isConnected <- S.sIsConnected clientSocket
+        case isConnected of
+            False -> Prelude.putStrLn "Tried to close client connection but was already closed"
+            True  -> do
+                        Prelude.putStrLn "Closing client connection..."
+                        handle
+                            (\(exception) ->
+                                case (exception :: ConnectionException) of
+                                    ConnectionClosed -> do
+                                                            Prelude.putStrLn "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"
+                            )
+                            ( sendClose clientConnection (T.pack "Shutting down..")
+                            )
+        join readerThread
+