Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Add isolate_ monad

  • Loading branch information...
commit ec650918694c23cf1299f0148ebc7da8f9f3497f 1 parent 36413bc
Jasper Van der Jeugt authored April 12, 2012
10  count-von-count/src/CountVonCount/Boxxy.hs
@@ -5,6 +5,10 @@ module CountVonCount.Boxxy
5 5
       BoxxyConfig (..)
6 6
     , defaultBoxxyConfig
7 7
 
  8
+      -- * State
  9
+    , Boxxies
  10
+    , newBoxxies
  11
+
8 12
       -- * Talking to boxxy
9 13
     , putConfig
10 14
     , putLaps
@@ -12,6 +16,7 @@ module CountVonCount.Boxxy
12 16
     ) where
13 17
 
14 18
 import Control.Applicative ((<$>),(<*>))
  19
+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar)
15 20
 import Control.Monad (mzero)
16 21
 import Data.Time (UTCTime)
17 22
 
@@ -62,6 +67,11 @@ defaultBoxxyConfig = BoxxyConfig
62 67
     , boxxyKey  = "tetten"
63 68
     }
64 69
 
  70
+type Boxxies = MVar [(BoxxyConfig, Bool)]
  71
+
  72
+newBoxxies :: [BoxxyConfig] -> IO Boxxies
  73
+newBoxxies = newMVar . map (flip (,) False)
  74
+
65 75
 makeRequest :: ToJSON a => BoxxyConfig -> Text -> a -> IO ()
66 76
 makeRequest config path body = do
67 77
     let rq = Http.def
2  count-von-count/src/CountVonCount/Counter.hs
@@ -70,7 +70,7 @@ step cl ms logger handler' event cmap = do
70 70
     return cmap'
71 71
   where
72 72
     process _      []     = return ()
73  
-    process cstate events = isolate logger "CounterEvent process" $ do
  73
+    process cstate events = isolate_ logger "CounterEvent process" $ do
74 74
         mteam  <- P.runPersistence $
75 75
             P.getTeamByMac (batonMac . sensorBaton $ event)
76 76
 
2  count-von-count/src/CountVonCount/Main.hs
@@ -38,7 +38,7 @@ main = do
38 38
     pubSub <- WS.newPubSub
39 39
 
40 40
     -- Initialize boxxy
41  
-    isolate logger "Initialize boxxy" $ do
  41
+    isolate_ logger "Initialize boxxy" $ do
42 42
         teams <- map snd <$> runPersistence getAllTeams
43 43
         forM_ (configBoxxies config) $ \boxxy -> putConfig boxxy
44 44
             (configCircuitLength config) (configStations config) teams
4  count-von-count/src/CountVonCount/Sensor.hs
@@ -63,10 +63,10 @@ listen logger port handler' = do
63 63
 
64 64
     forever $ do
65 65
         (conn, _) <- S.accept sock
66  
-        _ <- forkIO $ isolate logger "Sensor send config" $ do
  66
+        _ <- forkIO $ isolate_ logger "Sensor send config" $ do
67 67
             S.sendAll conn "MSG,enable_rssi,true\r\n"
68 68
             S.sendAll conn "MSG,enable_cache,false\r\n"
69  
-        _ <- forkIO $ isolate logger "Sensor receive" $ do
  69
+        _ <- forkIO $ isolate_ logger "Sensor receive" $ do
70 70
             E.run_ $ SE.enumSocket 256 conn $$
71 71
                 E.sequence (AE.iterParser gyrid) =$ receive logger handler'
72 72
             S.sClose conn
2  count-von-count/src/CountVonCount/Types.hs
@@ -72,7 +72,7 @@ batonName = ("Baton " ++) . show . batonNr
72 72
 data Handler a = Handler (Log -> a -> IO ())
73 73
 
74 74
 handler :: String -> (a -> IO ()) -> Handler a
75  
-handler name f = Handler $ \logger -> isolate logger ("Handler " ++ name) . f
  75
+handler name f = Handler $ \logger -> isolate_ logger ("Handler " ++ name) . f
76 76
 
77 77
 callHandler :: Log -> Handler a -> a -> IO ()
78 78
 callHandler logger (Handler f) = f logger
16  count-von-count/src/CountVonCount/Util.hs
... ...
@@ -1,6 +1,7 @@
1 1
 {-# LANGUAGE ScopedTypeVariables #-}
2 2
 module CountVonCount.Util
3 3
     ( isolate
  4
+    , isolate_
4 5
     ) where
5 6
 
6 7
 import qualified Control.Exception as E
@@ -8,12 +9,19 @@ import qualified Control.Exception as E
8 9
 import CountVonCount.Log
9 10
 
10 11
 -- | Isolate any exception in the given worker code and log it
11  
-isolate :: Log -> String -> IO () -> IO ()
12  
-isolate logger name worker = E.catches worker
  12
+isolate :: Log -> String -> IO () -> IO (Maybe E.SomeException)
  13
+isolate logger name worker = E.catches (worker >> return Nothing)
13 14
     [ E.Handler $ \async -> case async of
14 15
         E.UserInterrupt -> E.throw E.UserInterrupt
15  
-        _               -> isolate' async
  16
+        _               -> isolate' (E.SomeException async)
16 17
     , E.Handler $ \(ex :: E.SomeException) -> isolate' ex
17 18
     ]
18 19
   where
19  
-    isolate' ex = string logger $ "[isolate " ++ name ++ "]: caught " ++ show ex
  20
+    isolate' ex = do
  21
+        string logger $ "[isolate " ++ name ++ "]: caught " ++ show ex
  22
+        return (Just ex)
  23
+
  24
+isolate_ :: Log -> String -> IO () -> IO ()
  25
+isolate_ logger name worker = do
  26
+    _ <- isolate logger name worker
  27
+    return ()

0 notes on commit ec65091

Please sign in to comment.
Something went wrong with that request. Please try again.