glue 0.1.1.1 → 0.1.2

raw patch · 6 files changed

+116/−9 lines, 6 filesdep +gluedep +monad-loopsdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: glue, monad-loops

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• glue.cabal +10/−5
• src/Glue.hs +2/−0
• src/Glue/Batcher.hs +0/−3
• src/Glue/Preload.hs +57/−0
• src/Glue/Types.hs +7/−1
• test/Glue/PreloadSpec.hs +40/−0

@@ -1,5 +1,5 @@ name:                   glue-version:                0.1.1.1+version:                0.1.2 synopsis:               Make better services. description:            Implements common patterns used in building services that run smoothly and efficiently. license:                BSD3@@ -26,6 +26,7 @@                         Glue.Retry                         Glue.Batcher                         Glue.Stats+                        Glue.Preload   -- other-extensions:   build-depends:        base >=4.6 && <4.9,                         transformers,@@ -36,7 +37,8 @@                         unordered-containers,                         hashable,                         ekg-core >=0.1.0.4 && <1,-                        text+                        text,+                        monad-loops   ghc-options:          -rtsopts                         -Wall   hs-source-dirs:       src@@ -44,10 +46,10 @@  executable example   main-is:              Main.hs-  hs-source-dirs:       src,-                        example+  hs-source-dirs:       example   other-modules:        Glue.Example.BatcherExample   build-depends:        base ==4.*,+                        glue,                         transformers,                         transformers-base,                         lifted-base,@@ -57,6 +59,7 @@                         hashable,                         ekg-core,                         text,+                        monad-loops,                         async   default-language:     Haskell2010 @@ -64,7 +67,7 @@   build-depends:        base ==4.*,                         QuickCheck -any,                         quickcheck-instances,-                        hspec -any,+                        hspec >=2.1.10,                         transformers,                         transformers-base,                         lifted-base,@@ -74,6 +77,7 @@                         hashable,                         ekg-core,                         text,+                        monad-loops,                         async   other-modules:        Glue.CachingSpec                         Glue.FailoverSpec@@ -84,6 +88,7 @@                         Glue.StatsSpec                         Glue.CircuitBreakerSpec                         Glue.BatcherSpec+                        Glue.PreloadSpec                         Spec   ghc-options:          -rtsopts                         -Wall

@@ -12,6 +12,7 @@   , module Glue.Retry   , module Glue.Batcher   , module Glue.Stats+  , module Glue.Preload ) where  import Glue.Types@@ -23,6 +24,7 @@ import Glue.Retry import Glue.Batcher import Glue.Stats+import Glue.Preload  {- Done:

@@ -49,9 +49,6 @@ emptyBatch :: (Eq a, Hashable a) => RequestBatch a b emptyBatch = RequestBatch [] S.empty -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)      - processCalls :: (Eq a, Hashable a, MonadBaseControl IO m) => MultiGetService m a b -> RequestBatch a b -> m () processCalls service (RequestBatch pendings requests) = do                                                           result <- makeCall service requests

@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}++-- | Module containing a form of caching where values for given keys are preloaded ahead of time.+-- | Once warmed up requests for preloaded keys will be instant, with the values refreshed in the background.+module Glue.Preload(+    PreloadedOptions+  , defaultPreloadedOptions+  , preloadingService+) where++import Glue.Types+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.Monad.Trans.Control+import Control.Monad.IO.Class++-- | Options for determining behaviour of preloading services.+data PreloadedOptions a = PreloadedOptions {+  preloadedKeys             :: S.HashSet a,   -- ^ Keys to preload.+  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 -> PreloadedOptions a+defaultPreloadedOptions toPreload = PreloadedOptions {+  preloadedKeys           = toPreload,+  preloadingRefreshTimeMs = 30 * 1000+}++-- | Preloads the results of calls for given keys.+preloadingService :: (MonadIO m, MonadBaseControl IO m, Eq a, Hashable a)+                  => PreloadedOptions a              -- ^ Instance of 'PreloadedOptions' to configure the preloading functionality.+                  -> MultiGetService m a b           -- ^ The service to perform preloading of.+                  -> m (MultiGetService m a b, () -> m ())+preloadingService options service = do+  let !keysToPreload = preloadedKeys options+  !preloadedVar <- newEmptyMVar+  !shouldContinueVar <- newMVar True+  let !updatePreloaded = do+                            result <- makeCall service keysToPreload+                            _ <- tryTakeMVar preloadedVar+                            putMVar preloadedVar result+                            threadDelay (preloadingRefreshTimeMs options * 1000)+  _ <- fork $ L.whileM_ (readMVar shouldContinueVar) updatePreloaded+  let plService request = do+                            let fromPreloadKeys = S.intersection request keysToPreload+                            let fromServiceKeys = S.difference request keysToPreload+                            !fromPreload <- if S.null fromPreloadKeys then return M.empty else fmap (M.filterWithKey (\k -> \_ -> S.member k fromPreloadKeys)) $ getResult preloadedVar +                            !fromService <- if S.null fromServiceKeys then return M.empty else service fromServiceKeys+                            return $ M.union fromService fromPreload+  return (plService, \_ -> tryTakeMVar shouldContinueVar >> putMVar shouldContinueVar False)

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Module containing the root types and some support functionality. module Glue.Types(@@ -10,13 +11,14 @@   , multiGetToBasic   , basicToMultiGet   , getResult+  , makeCall ) where  import Control.Applicative import Data.Hashable import Control.Concurrent import qualified Control.Concurrent.MVar.Lifted as MV-import Control.Exception.Base hiding(throw, throwIO)+import Control.Exception.Base hiding(throw, throwIO, catch) import Control.Exception.Lifted hiding(throw) import Control.Monad.Trans.Control import qualified Data.HashSet as S@@ -50,3 +52,7 @@ getResult var = do   result <- MV.readMVar var   either throwIO return result++-- | 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)      

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.PreloadSpec where++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()++serviceFunctionality :: MultiGetRequest Int -> MultiGetResponse Int Int+serviceFunctionality rs = M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList rs++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) 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+      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) service+        takeMVar preloadCheck+        let expectedResults = serviceFunctionality (S.union preload nonPreload)+        actualResults <- preloadedService (S.union preload nonPreload)+        disable ()+        actualResults `shouldBe` expectedResults+