glue-core 0.6 → 0.6.1

raw patch · 3 files changed

+44/−24 lines, 3 files

Files

• glue-core.cabal +1/−1
• src/Glue/DogpileProtection.hs +40/−20
• test/Glue/RetrySpec.hs +3/−3

@@ -1,5 +1,5 @@ name:                   glue-core-version:                0.6+version:                0.6.1 synopsis:               Make better services and clients. description:            Combinator library to enhance the general functionality of services and clients. license:                BSD3

@@ -6,32 +6,52 @@   dogpileProtect ) where -import Control.Concurrent.Lifted-import Control.Exception.Lifted-import Control.Monad.Trans.Control+import Control.Concurrent+import Control.Exception import Data.Hashable import qualified Data.HashMap.Strict as M-import Data.IORef.Lifted+import Data.IORef import Glue.Types --- TODO: Should make this return just BasicService, hiding the HashMap.+data DogpileResult b = CachedValue (Either SomeException b)+                     | RequestInProgress (IO b)++type ResultMap a b = M.HashMap a (DogpileResult b)++type ResultRef a b = IORef (ResultMap a b)++getDogpileResult :: DogpileResult b -> IO b+getDogpileResult (RequestInProgress requestWait) = requestWait+getDogpileResult (CachedValue result) = either throw return result++waitForMVar :: MVar (Either SomeException b) -> IO b+waitForMVar mvar = do+  result <- readMVar mvar+  either throw return result++getProtectedResult :: (Eq a, Hashable a)+                   => a -> BasicService IO a b -> MVar (Either SomeException b) -> ResultRef a b -> ResultMap a b -> (ResultMap a b, IO b)+getProtectedResult request service mvar mapRef resultMap =+  let mvarWait = waitForMVar mvar+      invokeService = do+        result <- try $ service request+        putMVar mvar result+        atomicModifyIORef' mapRef (\mapToUpdate -> (M.insert request (CachedValue result) mapToUpdate, ()))+        forkIO $ do+          threadDelay (5 * 1000 * 1000)+          atomicModifyIORef' mapRef (\mapToUpdate -> (M.delete request mapToUpdate, ()))+      inCache = M.lookup request resultMap+  in  maybe (M.insert request (RequestInProgress mvarWait) resultMap, invokeService >> mvarWait) (\r -> (resultMap, getDogpileResult r)) inCache+ -- | Dogpile protection of a service, to prevent multiple calls for the same value being submitted. -- | Loses the values held within m.-dogpileProtect :: (MonadBaseControl IO m, MonadBaseControl IO n, Eq a, Hashable a) -               => BasicService m a b   -- ^ The service to protect.-               -> n (IORef (M.HashMap a (ResultVar b)), BasicService m a b)+dogpileProtect :: (Eq a, Hashable a)+               => BasicService IO a b   -- ^ The service to protect.+               -> IO (BasicService IO a b) dogpileProtect service = do   mapRef <- newIORef M.empty   let protectedService request = do-                                    firstRequestMVar <- newEmptyMVar -                                    resultAction <- atomicModifyIORef' mapRef (\refMap -> -                                        let removeFromMap           = atomicModifyIORef' mapRef (\m -> (M.delete request m, ()))-                                            invokeService           = do -                                                                        result <- bracketOnError (return ()) (\_ -> removeFromMap) (\_ -> service request)-                                                                        putMVar firstRequestMVar $ Right result-                                                                        return result-                                            updateMap mvar          = (M.insert request mvar refMap, getResult mvar)-                                            addToMap                = (M.insert request firstRequestMVar refMap, invokeService)-                                        in  maybe addToMap updateMap $ M.lookup request refMap)-                                    resultAction-  return (mapRef, protectedService)+        mvar <- newEmptyMVar+        resultAction <- atomicModifyIORef' mapRef $ getProtectedResult request service mvar mapRef+        resultAction+  return protectedService

@@ -26,7 +26,7 @@ spec = do   describe "retryingService" $ do     it "Attempts a service call multiple times" $ do-      property $ \(request, (SmallInt failures), (SmallInt retries)) -> +      property $ \(request, (SmallInt failures), (SmallInt retries)) ->         do           ref <- liftIO $ newIORef 0           let service req   = do@@ -40,11 +40,11 @@     it "Asynchronous exceptions are rethrown" $ do       property $ \(request, retries) ->          do-          ref <- liftIO $ newIORef 0+          ref <- liftIO $ newIORef (0 :: Int)           let service req   = do                                 atomicModifyIORef' ref (\c -> (c + 1, ()))                                 threadId <- myThreadId-                                forkIO (threadDelay 10000 >> throwTo threadId UserInterrupt)+                                _ <- forkIO (threadDelay 10000 >> throwTo threadId UserInterrupt)                                 threadDelay 1000000                                 return (req * 2 :: Int)           let options       = defaultRetryOptions { maximumRetries = retries }