diff --git a/glue.cabal b/glue.cabal --- a/glue.cabal +++ b/glue.cabal @@ -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 diff --git a/src/Glue.hs b/src/Glue.hs --- a/src/Glue.hs +++ b/src/Glue.hs @@ -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? diff --git a/src/Glue/Preload.hs b/src/Glue/Preload.hs --- a/src/Glue/Preload.hs +++ b/src/Glue/Preload.hs @@ -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) diff --git a/src/Glue/Switching.hs b/src/Glue/Switching.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Switching.hs @@ -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) diff --git a/src/Glue/Types.hs b/src/Glue/Types.hs --- a/src/Glue/Types.hs +++ b/src/Glue/Types.hs @@ -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) diff --git a/test/Glue/PreloadSpec.hs b/test/Glue/PreloadSpec.hs --- a/test/Glue/PreloadSpec.hs +++ b/test/Glue/PreloadSpec.hs @@ -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