glue-common 0.6.3 → 0.7.0

raw patch · 4 files changed

+160/−85 lines, 4 filesdep +unliftiodep −asyncdep −ekg-coredep −lifted-basedep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio

Dependencies removed: async, ekg-core, lifted-base, monad-control, text, time, transformers, transformers-base

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• glue-common.cabal +56/−53
• src/Glue/Types.hs +32/−30
• test/Glue/TypesSpec.hs +72/−0

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,59 +1,62 @@-name:                   glue-common-version:                0.6.3-synopsis:               Make better services and clients.-description:            Common types and base functions used in the glue family of libraries.-license:                BSD3-license-file:           LICENSE-author:                 Sean Parsons-maintainer:             github@futurenotfound.com-category:               Network-build-type:             Simple-cabal-version:          >=1.10+cabal-version:      3.0+name:               glue-common+version:            0.7.0+synopsis:           Make better services and clients.+description:        Common types and base functions used in the glue family of libraries.+license:            BSD-3-Clause+license-file:       LICENSE+author:             Sean Parsons+maintainer:         github@futurenotfound.com+category:           Network+build-type:         Simple+tested-with:        GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.3  source-repository head-  type:                 git-  location:             git://github.com/seanparsons/glue.git+  type:     git+  location: https://github.com/seanparsons/glue.git +common common-options+  default-language: Haskell2010+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wmissing-home-modules+    -Wpartial-fields+    -Wredundant-constraints+ library-  exposed-modules:      Glue.Types-  -- other-extensions:-  build-depends:        base >=4.6 && <5,-                        transformers,-                        transformers-base,-                        lifted-base,-                        time,-                        monad-control,-                        unordered-containers,-                        hashable,-                        text-  ghc-options:          -Wall-  hs-source-dirs:       src-  default-language:     Haskell2010+  import:          common-options+  hs-source-dirs:  src+  exposed-modules: Glue.Types+  build-depends:+    , base                  >= 4.16 && < 5+    , hashable+    , unliftio              >= 0.2+    , unordered-containers  test-suite glue-common-tests-  build-depends:        base >=4.6 && <5,-                        glue-common,-                        QuickCheck -any,-                        quickcheck-instances,-                        hspec,-                        transformers,-                        transformers-base,-                        lifted-base,-                        time,-                        monad-control,-                        unordered-containers,-                        hashable,-                        ekg-core,-                        text,-                        async-  other-modules:        Spec-  ghc-options:          -rtsopts-                        -Wall-                        -O2-                        -threaded-  build-tools:          hspec-discover-  type:                 exitcode-stdio-1.0-  main-is:              Main.hs-  buildable:            True-  default-language:     Haskell2010-  hs-source-dirs:       test+  import:             common-options+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Main.hs+  other-modules:+    Glue.TypesSpec+    Spec+  build-tool-depends: hspec-discover:hspec-discover+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N+    -O2+  build-depends:+    , base                  >= 4.16 && < 5+    , glue-common+    , hashable+    , hspec+    , QuickCheck+    , quickcheck-instances+    , unliftio              >= 0.2+    , unordered-containers

@@ -3,8 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-}  -- | Module containing the root types and some support functionality.-module Glue.Types(-    BasicService+module Glue.Types+  ( BasicService   , MultiGetService   , MultiGetRequest   , MultiGetResponse@@ -15,51 +15,53 @@   , basicToMultiGet   , getResult   , makeCall-) where+  ) where -import           Control.Applicative-import           Control.Concurrent-import qualified Control.Concurrent.MVar.Lifted as MV-import           Control.Exception.Base         hiding (catch, throw, throwIO)-import           Control.Exception.Lifted       hiding (throw)-import           Control.Monad.Trans.Control-import           Data.Hashable-import qualified Data.HashMap.Strict            as M-import qualified Data.HashSet                   as S+import           Data.Hashable       (Hashable)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import           UnliftIO            (MonadIO, MonadUnliftIO, SomeException)+import           UnliftIO.Exception  (throwIO, tryAny)+import           UnliftIO.MVar       (MVar, readMVar)  -- | Type alias for the most basic form of a service supported. type BasicService m a b = a -> m b--- | Type alias for the request portion of a `MultiGetService`.++-- | Type alias for the request portion of a 'MultiGetService'. type MultiGetRequest a = S.HashSet a--- | Type alias for the response portion of a `MultiGetService`.++-- | Type alias for the response portion of a 'MultiGetService'. type MultiGetResponse a b = M.HashMap a b+ -- | Type alias for a service that looks up multiple values and returns multiple results. type MultiGetService m a b = BasicService m (MultiGetRequest a) (MultiGetResponse a b)+ -- | Type alias for the common container of a result used in asynchronous calls. type ResultVar a = MVar (Either SomeException a)--- | Run the m into an IO instance for a response.++-- | Run the @m@ into an 'IO' instance for a response. type MToIO m = forall a. m a -> IO a+ -- | Type alias for either a failure or a successful response. type FailOrSuccess a b = Either SomeException (MultiGetResponse a b) --- | Convert a 'MultiGetService' into a 'BasicService' that looks up a single key, returning a `Maybe` which determines if the value was present.-multiGetToBasic :: (Hashable a, Eq a, Monad m) => MultiGetService m a b -> BasicService m a (Maybe b)-multiGetToBasic service = (\r -> do-  mapResult <- service (S.singleton r)-  return $ M.lookup r mapResult)+-- | Convert a 'MultiGetService' into a 'BasicService' that looks up a single key,+-- returning a 'Maybe' which determines if the value was present.+multiGetToBasic :: (Hashable a, Functor m) => MultiGetService m a b -> BasicService m a (Maybe b)+multiGetToBasic service r = M.lookup r <$> service (S.singleton r) --- | Convert a 'BasicService' into a 'MultiGetService'-basicToMultiGet :: (Hashable a, Eq a, Applicative m) => BasicService m a b -> MultiGetService m a b+-- | Convert a 'BasicService' into a 'MultiGetService'.+basicToMultiGet :: (Hashable a, Applicative m) => BasicService m a b -> MultiGetService m a b basicToMultiGet service =-  let callService resultMap request = liftA2 (flip $ M.insert request) resultMap (service request)+  let callService resultMap request = flip (M.insert request) <$> resultMap <*> service request   in  S.foldl' callService (pure M.empty) --- | Obtain a result from a 'ResultVar' in the 'Monad' of your choice.-getResult :: (MonadBaseControl IO m) => ResultVar a -> m a+-- | Obtain a result from a 'ResultVar' in the 'MonadIO' of your choice.+getResult :: MonadIO m => ResultVar a -> m a getResult var = do-  result <- MV.readMVar var-  either throwIO return result+  result <- readMVar var+  either throwIO pure 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 (FailOrSuccess a b)-makeCall service requests = catch (fmap Right $ service requests) (\(e :: SomeException) -> return $ Left e)+-- | Makes a multi-get call and handles synchronous errors by bundling them up inside an 'Either'.+makeCall :: MonadUnliftIO m => MultiGetService m a b -> S.HashSet a -> m (FailOrSuccess a b)+makeCall service requests = tryAny (service requests)

@@ -0,0 +1,72 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Glue.TypesSpec (spec) where++import qualified Data.HashMap.Strict       as M+import qualified Data.HashSet              as S+import           Glue.Types+import           Test.Hspec+import           Test.QuickCheck+import           Test.QuickCheck.Instances ()+import           UnliftIO.Exception        (Exception, SomeException (..),+                                            fromException, throwIO)+import           UnliftIO.MVar             (newMVar)++data TypesTestException = TypesTestException+  deriving (Eq, Show)++instance Exception TypesTestException++spec :: Spec+spec = do+  describe "multiGetToBasic and basicToMultiGet" $ do+    it "basicToMultiGet lifts a BasicService over a HashSet of requests" $+      property $ \(requests :: S.HashSet Int) -> do+        let basic :: BasicService IO Int Int+            basic x = pure (x * 2)+            multi = basicToMultiGet basic+            expected = M.fromList [ (k, k * 2) | k <- S.toList requests ]+        multi requests `shouldReturn` expected++    it "multiGetToBasic looks up a single key from a MultiGetService" $+      property $ \(resp :: MultiGetResponse Int Int, key :: Int) -> do+        let multi :: MultiGetService IO Int Int+            multi _ = pure resp+            basic = multiGetToBasic multi+        basic key `shouldReturn` M.lookup key resp++    it "multiGetToBasic . basicToMultiGet round-trips as Just" $+      property $ \(key :: Int) -> do+        let basic :: BasicService IO Int Int+            basic x = pure (x + 10)+            roundTripped = multiGetToBasic (basicToMultiGet basic)+        roundTripped key `shouldReturn` Just (key + 10)++  describe "getResult" $ do+    it "returns the value when ResultVar holds Right" $+      property $ \(val :: Int) -> do+        var <- newMVar (Right val)+        getResult var `shouldReturn` val++    it "rethrows the exception when ResultVar holds Left" $ do+      var <- newMVar (Left (SomeException TypesTestException) :: Either SomeException Int)+      getResult var `shouldThrow` (== TypesTestException)++  describe "makeCall" $ do+    it "returns Right on a successful multi-get call" $+      property $ \(requests :: S.HashSet Int) -> do+        let expected = M.fromList [ (k, k * 3) | k <- S.toList requests ]+            service :: MultiGetService IO Int Int+            service _ = pure expected+        result <- makeCall service requests+        case result of+          Right actual -> actual `shouldBe` expected+          Left err     -> expectationFailure $ "Unexpected failure: " <> show err++    it "captures synchronous exceptions in Left" $ do+      let service :: MultiGetService IO Int Int+          service _ = throwIO TypesTestException+      result <- makeCall service (S.singleton 1)+      case result of+        Left err -> fromException err `shouldBe` Just TypesTestException+        Right v  -> expectationFailure $ "Expected Left exception, got Right: " <> show v