glue-core 0.4.6 → 0.4.8

raw patch · 3 files changed

+37/−8 lines, 3 filesdep ~glue-common

Dependency ranges changed: glue-common

Files

• glue-core.cabal +3/−4
• src/Glue/Preload.hs +17/−1
• test/Glue/PreloadSpec.hs +17/−3

@@ -1,5 +1,5 @@ name:                   glue-core-version:                0.4.6+version:                0.4.8 synopsis:               Make better services and clients. description:            Combinator library to enhance the general functionality of services and clients. license:                BSD3@@ -26,7 +26,7 @@                         Glue.Switching   -- other-extensions:   build-depends:        base >=4.6 && <4.9,-                        glue-common == 0.4.6,+                        glue-common == 0.4.8,                         transformers,                         transformers-base,                         lifted-base,@@ -35,8 +35,7 @@                         unordered-containers,                         hashable,                         text-  ghc-options:          -rtsopts-                        -Wall+  ghc-options:          -Wall   hs-source-dirs:       src   default-language:     Haskell2010 

@@ -11,11 +11,13 @@     PreloadedOptions   , defaultPreloadedOptions   , preloadingService+  , preloadingCall   , preloadedKeys   , preloadingRefreshTimeMs   , preloadingRun ) where +import Data.Maybe import Glue.Types import Data.Hashable import Data.Typeable@@ -80,7 +82,7 @@   let runUpdate = do                     result <- makeCall service preloadedKeys                     applyResultToState stateIORef result-  let updatePreloaded = do                          +  let updatePreloaded = do                           continue <- liftIO $ preloadingRun $ runUpdate                           if continue then threadDelay (preloadingRefreshTimeMs * 1000) >> updatePreloaded else return ()   let plService request = do@@ -91,3 +93,17 @@                             return $ M.union fromService fromPreload   fork updatePreloaded   return (plService, stop)++-- | Preloads a single parameter-less call.+preloadingCall :: forall m n b . (MonadIO m, MonadIO n, MonadBaseControl IO m, MonadBaseControl IO n)+               => MToIO m                     -- ^ Get an IO of the call for the caching.+               -> Int                         -- ^ Amount of time between refreshes.+               -> m b                         -- ^ The call to perform preloading of.+               -> n (m b, () -> n ())+preloadingCall toIO timeBetweenRefreshes call = do+  let multiGetService = basicToMultiGet (\_ -> call) :: MultiGetService m () b+  let options = PreloadedOptions (S.singleton ()) timeBetweenRefreshes toIO+  (preloading, stop) <- preloadingService options multiGetService+  let preloadingBasicService = multiGetToBasic preloading+  let preloadingCallResult = fmap (fromJust) $ preloadingBasicService ()+  return (preloadingCallResult, stop)

@@ -18,12 +18,15 @@ failingService :: MultiGetRequest Int -> IO (MultiGetResponse Int Int) failingService _ = throwIO PreloadTestException +successfullCall :: IO Int+successfullCall = return 12++failingCall :: IO Int+failingCall = 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@@ -42,3 +45,14 @@         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+  describe "preloadingCall" $ do+    it "Requests should work" $ do+      property $ do+        (preloadedCall, disable) <- preloadingCall id 1000 successfullCall+        actualResults <- preloadedCall+        disable ()+        actualResults `shouldBe` 12+    it "Exceptions should propagate" $ do+      property $ do+        (preloadedCall, disable) <- preloadingCall id 1000 failingCall+        preloadedCall `shouldThrow` (== PreloadTestException)