glue 0.1.2 → 0.1.3

raw patch · 6 files changed

+91/−25 lines, 6 filesnew-component:exe:glue-examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• glue.cabal +3/−3
• readme.md +64/−0
• src/Glue.hs +1/−1
• src/Glue/Batcher.hs +4/−4
• src/Glue/Preload.hs +17/−15
• test/Glue/PreloadSpec.hs +2/−2

@@ -1,5 +1,5 @@ name:                   glue-version:                0.1.2+version:                0.1.3 synopsis:               Make better services. description:            Implements common patterns used in building services that run smoothly and efficiently. license:                BSD3@@ -8,7 +8,7 @@ maintainer:             github@futurenotfound.com category:               Network build-type:             Simple--- extra-source-files:+extra-source-files:     readme.md cabal-version:          >=1.10  source-repository head@@ -44,7 +44,7 @@   hs-source-dirs:       src   default-language:     Haskell2010 -executable example+executable glue-example   main-is:              Main.hs   hs-source-dirs:       example   other-modules:        Glue.Example.BatcherExample

@@ -0,0 +1,64 @@+Building Better Services+========================++[![Build Status](https://secure.travis-ci.org/seanparsons/glue.svg)](http://travis-ci.org/seanparsons/glue)++This package provides methods to deal with the common needs of services talking to other services, like timeouts and retries, treating these as cross-cutting concerns that aren't tied to a specific transport like HTTP.++Examples+========++Batching+--------++In a social network there may be another service that returns user records, if this social network is really busy it would likely be more efficient to capture multiple calls and dispatch them as one multi-get call.++The batchingService function creates both single and multi-get calls (hence the "fmap snd" below), which accumulate requests over a user defined window in time and dispatch them once that window has passed.++```haskell+data User = User Int String++makeUser :: Int -> User+makeUser userId = User userId ("User " ++ (show userId))++userService :: S.HashSet Int -> IO (M.HashMap Int User)+userService request = do+  threadDelay 500+  return $ M.fromList $ fmap (\r -> (r, makeUser r)) $ S.toList request++batchedUserService :: IO (S.HashSet Int -> IO (M.HashMap Int User))+batchedUserService = fmap snd $ batchingService defaultBatchingOptions userService+```+++Retries+-------++Often we want to retry service calls if they've failed because it might've been a transient error that subsequently succeeds.++```haskell+failingService :: IORef Int -> Int -> IO Int+failingService ref request = do+  counter <- atomicModifyIORef' ref (\c -> (c + 1, c + 1))+  if counter `mod` 3 == 0 then fail "Bang!" else return (request * 2)++notSoFailingService :: IO (Int -> IO Int)+notSoFailingService = do+  ref <- liftIO $ newIORef 0+  return $ retryingService defaultRetryOptions $ failingService ref+```++Caching+-------++```haskell+serviceThatNeedsCaching :: Int -> IO Int+serviceThatNeedsCaching request = do+  putStrLn "Doing Something Expensive!"+  return (request * 2)++cachedService :: IO (Int -> IO Int)+cachedService = do+  cache <- newAtomicLRU $ Just 100+  return $ cacheWithLRU cache serviceThatNeedsCaching+```

@@ -36,6 +36,7 @@ - Retries. - Multi-get optimisations. - Performance stats.+- Preloading.  Todo: - Load balancer, maybe just a simple round robin to start with.@@ -44,5 +45,4 @@ - 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?-- Caching that supports refreshing invisibly to the consumer? -}

@@ -21,7 +21,7 @@ import Data.IORef.Lifted import Glue.Types --- | Options for configuring the batching. +-- | Options for configuring the batching. data BatchingOptions = BatchingOptions {     batchWindowMs :: Int           -- ^ Window in milliseconds over which to batch. } deriving (Eq, Show)@@ -36,7 +36,7 @@ data RequestBatch a b = RequestBatch [PendingRequest a b] (MultiGetRequest a)  -- | Individual request to satisfy, for either a single key or a multi request.-data PendingRequest a b = +data PendingRequest a b =   SingleRequest a (ResultVar (Maybe b)) |   MultiRequest (MultiGetRequest a) (ResultVar (MultiGetResponse a b)) @@ -52,7 +52,7 @@ 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-                                                          traverse_ (applyToPending result) pendings              +                                                          traverse_ (applyToPending result) pendings  startBatch :: (Eq a, Hashable a, MonadBaseControl IO m) => BatchingOptions -> MultiGetService m a b -> IORef (RequestBatch a b) -> m () startBatch options service ref = fmap (\_ -> ()) $ fork $ do@@ -75,7 +75,7 @@                                               mvar <- newEmptyMVar                                               let pending = MultiRequest requests mvar                                               addPending options service ref pending-                                              getResult mvar  +                                              getResult mvar  -- | Function for constructing a batching service. batchingService :: (Eq a, Hashable a, MonadBaseControl IO m, Applicative m, MonadBaseControl IO n)

@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}  -- | 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.@@ -21,36 +22,37 @@ import Control.Monad.IO.Class  -- | Options for determining behaviour of preloading services.-data PreloadedOptions a = PreloadedOptions {+data PreloadedOptions a m n = PreloadedOptions {   preloadedKeys             :: S.HashSet a,   -- ^ Keys to preload.-  preloadingRefreshTimeMs   :: Int            -- ^ Amount of time between refreshes.+  preloadingRefreshTimeMs   :: Int,           -- ^ Amount of time between refreshes.+  executePreload            :: m () -> n ()   -- ^ How to run the preload action. }  -- | Defaulted options for preloading a HashSet of keys with a 30 second refresh time.-defaultPreloadedOptions :: S.HashSet a -> PreloadedOptions a-defaultPreloadedOptions toPreload = PreloadedOptions {+defaultPreloadedOptions :: S.HashSet a -> (m () -> n ()) -> PreloadedOptions a m n+defaultPreloadedOptions toPreload executeP = PreloadedOptions {   preloadedKeys           = toPreload,-  preloadingRefreshTimeMs = 30 * 1000+  preloadingRefreshTimeMs = 30 * 1000,+  executePreload          = executeP }  -- | 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.+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.-                  -> m (MultiGetService m a b, () -> m ())-preloadingService options service = do-  let !keysToPreload = preloadedKeys options+                  -> n (MultiGetService m a b, () -> n ())+preloadingService PreloadedOptions{..} service = do   !preloadedVar <- newEmptyMVar   !shouldContinueVar <- newMVar True   let !updatePreloaded = do-                            result <- makeCall service keysToPreload+                            result <- makeCall service preloadedKeys                             _ <- tryTakeMVar preloadedVar                             putMVar preloadedVar result-                            threadDelay (preloadingRefreshTimeMs options * 1000)-  _ <- fork $ L.whileM_ (readMVar shouldContinueVar) updatePreloaded+                            threadDelay (preloadingRefreshTimeMs * 1000)+  _ <- fork $ L.whileM_ (readMVar shouldContinueVar) $ executePreload $ updatePreloaded   let plService request = do-                            let fromPreloadKeys = S.intersection request keysToPreload-                            let fromServiceKeys = S.difference request keysToPreload+                            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                              !fromService <- if S.null fromServiceKeys then return M.empty else service fromServiceKeys                             return $ M.union fromService fromPreload

@@ -20,7 +20,7 @@     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+        (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload id) service         let expectedResults = serviceFunctionality (S.union preload nonPreload)         actualResults <- preloadedService (S.union preload nonPreload)         disable ()@@ -31,7 +31,7 @@         let service rs = do                             _ <- tryPutMVar preloadCheck ()                             return $ serviceFunctionality rs-        (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload) service+        (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload id) service         takeMVar preloadCheck         let expectedResults = serviceFunctionality (S.union preload nonPreload)         actualResults <- preloadedService (S.union preload nonPreload)