glue-example 0.6.3 → 0.7.0
raw patch · 3 files changed
+65/−54 lines, 3 filesdep +unliftiodep −asyncdep −hashabledep −lifted-basedep ~basedep ~glue-commondep ~glue-coresetup-changed
Dependencies added: unliftio
Dependencies removed: async, hashable, lifted-base, monad-control, monad-loops, time, transformers, transformers-base
Dependency ranges changed: base, glue-common, glue-core, glue-ekg
Files
- Setup.hs +0/−2
- glue-example.cabal +43/−32
- src/Glue/Example/BatcherExample.hs +22/−20
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
glue-example.cabal view
@@ -1,36 +1,47 @@-name: glue-example-version: 0.6.3-synopsis: Make better services and clients.-description: Examples of the use of glue library functionality.-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-example+version: 0.7.0+synopsis: Make better services and clients.+description: Examples of the use of glue library functionality.+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+ executable glue-example- main-is: Main.hs- hs-source-dirs: src- other-modules: Glue.Example.BatcherExample- build-depends: base >=4.6 && <5,- glue-common ==0.6.3,- glue-core ==0.6.3,- glue-ekg ==0.6.3,- transformers,- transformers-base,- lifted-base,- time,- monad-control,- unordered-containers,- hashable,- ekg-core,- text,- monad-loops,- async- default-language: Haskell2010+ import: common-options+ main-is: Main.hs+ hs-source-dirs: src+ other-modules: Glue.Example.BatcherExample+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends:+ , base >= 4.16 && < 5+ , ekg-core+ , glue-common ^>= 0.7.0+ , glue-core ^>= 0.7.0+ , glue-ekg ^>= 0.7.0+ , text+ , unliftio >= 0.2+ , unordered-containers
src/Glue/Example/BatcherExample.hs view
@@ -1,47 +1,49 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Glue.Example.BatcherExample(- batcherExample-) where+module Glue.Example.BatcherExample+ ( batcherExample+ ) where -import Control.Concurrent.Async-import Control.Concurrent.Lifted import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S-import Data.IORef.Lifted import qualified Data.List as L-import Data.Text-import Data.Traversable+import Data.Text (Text, unpack) import Glue.Batcher import Glue.Ekg import System.Metrics import qualified System.Metrics.Distribution as D-import Text.Printf+import Text.Printf (printf)+import UnliftIO.Async (mapConcurrently_)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.IORef (atomicModifyIORef', newIORef) printStats :: Store -> Text -> IO () printStats store name = do samples <- sampleAll store let possibleValue = M.lookup name samples case possibleValue of- (Just (Distribution stats)) -> printf "%s - sum : %f - count : %d" (unpack name) (D.sum stats) (D.count stats) >> putStrLn ""- otherwise -> return ()+ Just (Distribution stats) -> printf "%s - sum : %f - count : %d\n" (unpack name) (D.sum stats) (D.count stats)+ _ -> pure () runTest :: Store -> Text -> Bool -> IO () runTest store name shouldBatch = do- counter <- newIORef 0- let listOfNums = [1..50]- let requests = fmap (S.fromList . L.take 10) $ L.tails listOfNums :: [S.HashSet Int]+ counter <- newIORef (0 :: Int)+ let listOfNums = [1 .. 50 :: Int]+ let requests = fmap (S.fromList . L.take 10) (L.tails listOfNums) let service request = do- atomicModifyIORef' counter (\c -> (c + (S.size request), ()))- threadDelay (500 * S.size request)- return $ M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList request+ atomicModifyIORef' counter (\c -> (c + S.size request, ()))+ threadDelay (500 * S.size request)+ pure $ M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList request statsWrappedService <- recordDistribution store name service- possiblyBatchedService <- if shouldBatch then return statsWrappedService else fmap (\(_, b) -> b) $ batchingService defaultBatchingOptions statsWrappedService- (mapConcurrently possiblyBatchedService requests)+ possiblyBatchedService <-+ if shouldBatch+ then snd <$> batchingService defaultBatchingOptions statsWrappedService+ else pure statsWrappedService+ mapConcurrently_ possiblyBatchedService requests printStats store name --- Tests the batchingService by comparing the stats with and without it.+-- | Tests the 'batchingService' by comparing the stats with and without it. batcherExample :: IO () batcherExample = do store <- newStore