glue 0.1.3 → 0.2.0

raw patch · 6 files changed

+100/−43 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• glue.cabal +5/−6
• src/Glue.hs +1/−1
• src/Glue/Preload.hs +49/−21
• src/Glue/Switching.hs +26/−0
• src/Glue/Types.hs +2/−2
• test/Glue/PreloadSpec.hs +17/−13

@@ -1,5 +1,5 @@ name:                   glue-version:                0.1.3+version:                0.2.0 synopsis:               Make better services. description:            Implements common patterns used in building services that run smoothly and efficiently. license:                BSD3@@ -12,8 +12,8 @@ cabal-version:          >=1.10  source-repository head-  type:                git-  location:            git://github.com/seanparsons/glue.git+  type:                 git+  location:             git://github.com/seanparsons/glue.git  library   exposed-modules:      Glue@@ -27,6 +27,7 @@                         Glue.Batcher                         Glue.Stats                         Glue.Preload+                        Glue.Switching   -- other-extensions:   build-depends:        base >=4.6 && <4.9,                         transformers,@@ -37,8 +38,7 @@                         unordered-containers,                         hashable,                         ekg-core >=0.1.0.4 && <1,-                        text,-                        monad-loops+                        text   ghc-options:          -rtsopts                         -Wall   hs-source-dirs:       src@@ -77,7 +77,6 @@                         hashable,                         ekg-core,                         text,-                        monad-loops,                         async   other-modules:        Glue.CachingSpec                         Glue.FailoverSpec

@@ -37,11 +37,11 @@ - Multi-get optimisations. - Performance stats. - Preloading.+- Switching.  Todo: - Load balancer, maybe just a simple round robin to start with. - Concurrent request constraint, possibly X inflight and Y queued.-- Switching service, allowing different implementations to be switched in and out at runtime. - Routing service? Possibly something akin to HTTP routing in a lot of web frameworks. - Request duplication, with completion based on the first successful result. - Graceful service shutdown, reject new requests with a default value, wait for a period of time while existing requests continue. Then possibly a cancel action?

@@ -16,44 +16,72 @@ import Data.Hashable import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M-import qualified Control.Monad.Loops as L import Control.Concurrent.Lifted+import Control.Exception.Base hiding (throwIO)+import Control.Exception.Lifted+import Data.IORef.Lifted import Control.Monad.Trans.Control import Control.Monad.IO.Class  -- | Options for determining behaviour of preloading services.-data PreloadedOptions a m n = PreloadedOptions {+data PreloadedOptions a = PreloadedOptions {   preloadedKeys             :: S.HashSet a,   -- ^ Keys to preload.-  preloadingRefreshTimeMs   :: Int,           -- ^ Amount of time between refreshes.-  executePreload            :: m () -> n ()   -- ^ How to run the preload action.+  preloadingRefreshTimeMs   :: Int            -- ^ Amount of time between refreshes. }  -- | Defaulted options for preloading a HashSet of keys with a 30 second refresh time.-defaultPreloadedOptions :: S.HashSet a -> (m () -> n ()) -> PreloadedOptions a m n-defaultPreloadedOptions toPreload executeP = PreloadedOptions {+defaultPreloadedOptions :: S.HashSet a -> PreloadedOptions a+defaultPreloadedOptions toPreload = PreloadedOptions {   preloadedKeys           = toPreload,-  preloadingRefreshTimeMs = 30 * 1000,-  executePreload          = executeP+  preloadingRefreshTimeMs = 30 * 1000 } +data PreloadedState a b = PreloadedNotStarted+                        | PreloadedStarted+                        | PreloadedWithResult (Either SomeException (MultiGetResponse a b))+                        | PreloadedFinished++updatePreloadState :: PreloadedState a b -> (PreloadedState a b, Bool)+updatePreloadState PreloadedNotStarted  = (PreloadedStarted, True)+updatePreloadState state                = (state, False)++applyResultToState :: MonadBaseControl IO m => IORef (PreloadedState a b) -> Either SomeException (MultiGetResponse a b) -> m Bool+applyResultToState stateRef result = do+  state <- readIORef stateRef+  case state of+                PreloadedFinished   -> return False+                PreloadedNotStarted -> return True+                _                   -> (writeIORef stateRef $ PreloadedWithResult result) >> return True++waitForResult :: MonadBaseControl IO m => IORef (PreloadedState a b) -> m (MultiGetResponse a b)+waitForResult stateRef = do+                            state <- readIORef stateRef+                            let tryAgainLater = threadDelay 1000 >> waitForResult stateRef+                            case state of+                                          PreloadedNotStarted                     -> tryAgainLater+                                          PreloadedStarted                        -> tryAgainLater+                                          PreloadedWithResult (Right success)     -> return success+                                          PreloadedWithResult (Left failure)      -> throwIO failure+                                          PreloadedFinished                       -> throwIO $ AssertionFailed "Invalid State"+ -- | Preloads the results of calls for given keys.-preloadingService :: (MonadIO m, MonadBaseControl IO m, MonadBaseControl IO n, Eq a, Hashable a)-                  => PreloadedOptions a m n          -- ^ Instance of 'PreloadedOptions' to configure the preloading functionality.-                  -> MultiGetService m a b           -- ^ The service to perform preloading of.+preloadingService :: forall m n a b . (MonadIO m, MonadBaseControl IO m, MonadBaseControl IO n, Eq a, Hashable a, Show a)+                  => PreloadedOptions a          -- ^ Instance of 'PreloadedOptions' to configure the preloading functionality.+                  -> MultiGetService m a b       -- ^ The service to perform preloading of.                   -> n (MultiGetService m a b, () -> n ()) preloadingService PreloadedOptions{..} service = do-  !preloadedVar <- newEmptyMVar-  !shouldContinueVar <- newMVar True-  let !updatePreloaded = do-                            result <- makeCall service preloadedKeys-                            _ <- tryTakeMVar preloadedVar-                            putMVar preloadedVar result-                            threadDelay (preloadingRefreshTimeMs * 1000)-  _ <- fork $ L.whileM_ (readMVar shouldContinueVar) $ executePreload $ updatePreloaded+  !stateIORef <- newIORef PreloadedNotStarted+  let stop _ = writeIORef stateIORef PreloadedFinished+  let updatePreloaded = do+                          result <- makeCall service preloadedKeys+                          continue <- applyResultToState stateIORef result+                          if continue then (threadDelay (preloadingRefreshTimeMs * 1000) >> updatePreloaded) else return ()   let plService request = do+                            shouldStart <- atomicModifyIORef' stateIORef updatePreloadState+                            if shouldStart then fork updatePreloaded >> return () else return ()                             let fromPreloadKeys = S.intersection request preloadedKeys                             let fromServiceKeys = S.difference request preloadedKeys-                            !fromPreload <- if S.null fromPreloadKeys then return M.empty else fmap (M.filterWithKey (\k -> \_ -> S.member k fromPreloadKeys)) $ getResult preloadedVar +                            !fromPreload <- if S.null fromPreloadKeys then return M.empty else fmap (M.filterWithKey (\k -> \_ -> S.member k fromPreloadKeys)) $ waitForResult stateIORef                             !fromService <- if S.null fromServiceKeys then return M.empty else service fromServiceKeys                             return $ M.union fromService fromPreload-  return (plService, \_ -> tryTakeMVar shouldContinueVar >> putMVar shouldContinueVar False)+  return (plService, stop)

@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}++-- | Module containing a switchable service, allowing the possibility of changing+-- | a service "live".+module Glue.Switching(+    switchingService+) where++import Glue.Types+import Control.Monad.Base+import Data.IORef.Lifted++-- | Provides a switchable service.+switchingService :: (MonadBase IO m, MonadBase IO n) => MultiGetService m a b  -- ^ The service to initialise the switching service with.+                 -> n (MultiGetService m a b, (MultiGetService m a b) -> n ())+switchingService service = do+  !serviceRef <- newIORef service+  let switching rs = do+                        serviceToUse <- readIORef serviceRef+                        serviceToUse rs+  let switchingUpdate newService = writeIORef serviceRef newService+  return (switching, switchingUpdate)

@@ -43,7 +43,7 @@  -- | Convert a 'BasicService' into a 'MultiGetService' basicToMultiGet :: (Hashable a, Eq a, Applicative m) => BasicService m a b -> MultiGetService m a b-basicToMultiGet service = +basicToMultiGet service =   let callService resultMap request = liftA2 (flip $ M.insert request) resultMap (service request)   in  S.foldl' callService (pure M.empty) @@ -55,4 +55,4 @@  -- | Makes a multi-get call and handles the error bundling it up inside an 'Either'. makeCall :: (Eq a, Hashable a, MonadBaseControl IO m) => MultiGetService m a b -> S.HashSet a -> m (Either SomeException (M.HashMap a b))-makeCall service requests = catch (fmap Right $ service requests) (\(e :: SomeException) -> return $ Left e)      +makeCall service requests = catch (fmap Right $ service requests) (\(e :: SomeException) -> return $ Left e)

@@ -4,37 +4,41 @@  import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M-import Control.Concurrent import Glue.Preload import Glue.Types import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances()+import Control.Exception.Base+import Data.Typeable  serviceFunctionality :: MultiGetRequest Int -> MultiGetResponse Int Int serviceFunctionality rs = M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList rs +failingService :: MultiGetRequest Int -> IO (MultiGetResponse Int Int)+failingService _ = throwIO PreloadTestException++data PreloadTestException = PreloadTestException deriving (Eq, Show, Typeable)+instance Exception PreloadTestException++handler :: SomeException -> IO (M.HashMap Int Int)+handler e = print e >> return M.empty+ spec :: Spec spec = do   describe "preloadingService" $ do     it "Requests should work the same regardless of whether or not parts are preloaded" $ do       property $ \(preload :: S.HashSet Int, nonPreload :: S.HashSet Int) -> do         let service = (return . serviceFunctionality) :: MultiGetService IO Int Int-        (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload id) service+        (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload) service         let expectedResults = serviceFunctionality (S.union preload nonPreload)         actualResults <- preloadedService (S.union preload nonPreload)         disable ()         actualResults `shouldBe` expectedResults-    it "Preloaded elements will preload before a request" $ do+    it "Exceptions should propagate" $ do       property $ \(preload :: S.HashSet Int, nonPreload :: S.HashSet Int) -> do-        preloadCheck <- newEmptyMVar-        let service rs = do-                            _ <- tryPutMVar preloadCheck ()-                            return $ serviceFunctionality rs-        (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload id) service-        takeMVar preloadCheck+        (preloadedService, _) <- preloadingService (defaultPreloadedOptions preload) failingService         let expectedResults = serviceFunctionality (S.union preload nonPreload)-        actualResults <- preloadedService (S.union preload nonPreload)-        disable ()-        actualResults `shouldBe` expectedResults-+        let goodPath = preloadedService (S.union preload nonPreload) `shouldReturn` expectedResults+        let badPath = preloadedService (S.union preload nonPreload) `shouldThrow` (== PreloadTestException)+        if (S.null preload && S.null nonPreload) then goodPath else badPath