avers 0.0.6 → 0.0.7
raw patch · 8 files changed
+324/−56 lines, 8 filesdep +aversdep +clockdep +criteriondep −influxdbdep ~basedep ~rethinkdb-client-driverdep ~template-haskell
Dependencies added: avers, clock, criterion, filepath, hspec
Dependencies removed: influxdb
Dependency ranges changed: base, rethinkdb-client-driver, template-haskell
Files
- avers.cabal +56/−3
- benchmark/Benchmark.hs +141/−0
- src/Avers.hs +4/−0
- src/Avers/Metrics.hs +17/−27
- src/Avers/Metrics/Measurements.hs +6/−0
- src/Avers/Storage.hs +15/−21
- src/Avers/Types.hs +5/−5
- test/Test.hs +80/−0
avers.cabal view
@@ -1,5 +1,5 @@ name: avers-version: 0.0.6+version: 0.0.7 license: GPL-3 license-file: LICENSE author: Tomas Carnecky@@ -29,6 +29,7 @@ exposed-modules: Avers , Avers.Metrics+ , Avers.Metrics.Measurements , Avers.Patching , Avers.Storage , Avers.Storage.Backend@@ -45,11 +46,13 @@ , attoparsec , base <= 9999 , bytestring+ , clock >= 0.4.4.0 && < 0.5 , containers+ , filepath , mtl , network , stm- , template-haskell+ , template-haskell >= 2.10 , text , time , unordered-containers@@ -61,7 +64,57 @@ , base16-bytestring , cryptohash , inflections- , influxdb , resource-pool , rethinkdb-client-driver >= 0.0.17 , scrypt++++benchmark benchmark+ hs-source-dirs: benchmark+ default-language: Haskell2010++ ghc-options: -threaded -Wall -O2 -rtsopts++ type: exitcode-stdio-1.0+ main-is: Benchmark.hs++ build-depends:+ aeson+ , avers+ , base+ , mtl+ , criterion+ , resource-pool+ , rethinkdb-client-driver >= 0.0.11+ , text+++test-suite spec+ hs-source-dirs: test+ default-language: Haskell2010++ type: exitcode-stdio-1.0+ main-is: Test.hs++ build-depends:+ MonadRandom+ , aeson+ , attoparsec+ , avers+ , base+ , base16-bytestring+ , bytestring+ , containers+ , cryptohash+ , hspec+ , inflections+ , mtl+ , resource-pool+ , rethinkdb-client-driver >= 0.0.11+ , scrypt+ , stm+ , text+ , time+ , unordered-containers+ , vector
+ benchmark/Benchmark.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where+++import Control.Applicative+import Control.Monad+import Control.Monad.State++import Data.Monoid+import Data.IORef+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T++import System.Environment+import System.IO.Unsafe++import Criterion.Main++import Avers+import Avers.TH+import Avers.Storage++import Prelude+++data Dummy = Dummy+ { dummyField :: Text+ } deriving (Show)++dummyObjectType :: ObjectType Dummy+dummyObjectType = ObjectType+ { otType = "dummy"+ , otId = ObjId <$> liftIO (newId 30)+ , otViews = []+ }+++databaseConfig :: IO (Text, Text)+databaseConfig = do+ host <- fromMaybe "localhost" <$> lookupEnv "RETHINKDB"+ database <- fromMaybe "test" <$> lookupEnv "DATABASE"+ return (T.pack host, T.pack database)+++mkBenchmarkHandle :: IO AversState+mkBenchmarkHandle = do+ (host, db) <- databaseConfig+ let config = AversConfig host db undefined [SomeObjectType dummyObjectType] (\_ _ -> return ())+ newState config+++{-# NOINLINE aversStateRef #-}+aversStateRef :: IORef AversState+aversStateRef = unsafePerformIO $ do+ newIORef =<< mkBenchmarkHandle+++benchAvers :: Avers a -> IO ()+benchAvers m = do+ h <- readIORef aversStateRef+ void $ evalAvers h m+++bench_Storage :: ObjId -> Benchmark+bench_Storage objId+ = bgroup "Storage"+ [ bench_Storage_lookupObject objId+ , bench_Storage_newestSnapshot objId+ , bench_Storage_patchesAfterRevision objId+ , bench_Storage_lookupLatestSnapshot objId+ ]++bench_Storage_lookupObject :: ObjId -> Benchmark+bench_Storage_lookupObject objId+ = bench "lookupObject" $ nfIO $ benchAvers $ do+ Avers.Storage.lookupObject objId++bench_Storage_newestSnapshot :: ObjId -> Benchmark+bench_Storage_newestSnapshot objId+ = bench "newestSnapshot" $ nfIO $ benchAvers $ do+ newestSnapshot (BaseObjectId objId)++bench_Storage_patchesAfterRevision :: ObjId -> Benchmark+bench_Storage_patchesAfterRevision objId+ = bgroup "patchesAfterRevision"+ [ bench_Storage_patchesAfterRevision_empty objId+ , bench_Storage_patchesAfterRevision_partial objId+ , bench_Storage_patchesAfterRevision_all objId+ ]++bench_Storage_patchesAfterRevision_empty :: ObjId -> Benchmark+bench_Storage_patchesAfterRevision_empty objId+ = bench "empty" $ nfIO $ benchAvers $ do+ patchesAfterRevision (BaseObjectId objId) (RevId 9999)++bench_Storage_patchesAfterRevision_partial :: ObjId -> Benchmark+bench_Storage_patchesAfterRevision_partial objId+ = bench "partial" $ nfIO $ benchAvers $ do+ patchesAfterRevision (BaseObjectId objId) (RevId 50)++bench_Storage_patchesAfterRevision_all :: ObjId -> Benchmark+bench_Storage_patchesAfterRevision_all objId+ = bench "all" $ nfIO $ benchAvers $ do+ patchesAfterRevision (BaseObjectId objId) zeroRevId++bench_Storage_lookupLatestSnapshot :: ObjId -> Benchmark+bench_Storage_lookupLatestSnapshot objId+ = bench "lookupLatestSnapshot" $ nfIO $ benchAvers $ do+ lookupLatestSnapshot (BaseObjectId objId)++++main :: IO ()+main = do+ h <- mkBenchmarkHandle+ Right objId <- evalAvers h $ do+ objId <- createObject dummyObjectType rootObjId (Dummy "dummy")+ forM_ [0..100] $ \(rev :: Int) -> do+ applyObjectUpdates+ (BaseObjectId objId)+ (RevId rev)+ rootObjId+ [Set (Path "field") (Just $ toJSON $ "dummy" <> T.pack (show rev))]+ False++ return objId++ putStrLn $ "Dummy object with id " ++ show objId+ Right res <- evalAvers h $ objectContent (BaseObjectId objId)+ print (res :: Dummy)++ defaultMain+ [ bench_Storage objId+ ]+++deriveEncoding (deriveJSONOptions "dummy") ''Dummy
src/Avers.hs view
@@ -103,6 +103,9 @@ , Index(..) , SomeIndex(..) + -- * Metrics+ , Measurement(..)+ , measurementLabels ) where @@ -113,3 +116,4 @@ import Avers.Types import Avers.Views import Avers.Index+import Avers.Metrics.Measurements
src/Avers/Metrics.hs view
@@ -1,39 +1,29 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}- module Avers.Metrics where -import Control.Concurrent-import Control.Monad.State -import Data.Text (Text)--import Network.BSD+import Control.Monad.State+import Control.Exception.Base -import Database.InfluxDB-import Database.InfluxDB.TH+import System.Clock import Avers.Types+import Avers.Metrics.Measurements -data Point = Point- { pointMachine :: String- , pointComponent :: Text- , pointValue :: Double- } +measureDuration :: Measurement -> Avers a -> Avers a+measureDuration m a = do+ start <- liftIO $ getTime Monotonic+ ret <- a >>= liftIO . evaluate+ end <- liftIO $ getTime Monotonic -reportPoint :: Text -> Double -> Avers ()-reportPoint series value = do- ac <- gets config- case influxConfig ac of- Nothing -> return ()- Just cfg -> void $ liftIO $ forkIO $ do- h <- getHostName- postWithPrecision cfg "rmx" SecondsPrecision $ withSeries series $ do- writePoints $ Point h "api" value+ reportMeasurement m+ (fromIntegral (timeSpecAsNanoSecs (diffTimeSpec start end)) / 1000000000) + return ret -deriveSeriesData defaultOptions- { fieldLabelModifier = stripPrefixLower "point" }- ''Point++reportMeasurement :: Measurement -> Double -> Avers ()+reportMeasurement m value = do+ conf <- gets config+ liftIO $ emitMeasurement conf m value
+ src/Avers/Metrics/Measurements.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}++module Avers.Metrics.Measurements (Measurement(..), measurementLabels) where++import Avers.Metrics.TH+mkMeasurements
src/Avers/Storage.hs view
@@ -48,6 +48,7 @@ import Crypto.Scrypt import Avers.Metrics+import Avers.Metrics.Measurements import Avers.Types import Avers.Patching import Avers.TH@@ -75,29 +76,16 @@ snapshotsTable = R.Table Nothing $ R.lift ("snapshots" :: Text) -trace :: String -> Avers a -> Avers a-trace label act = do- start <- liftIO $ getCurrentTime- ret <- act- end <- liftIO $ getCurrentTime-- reportPoint- ("avers.storage." <> (T.pack label) <> ".duration")- (realToFrac $ diffUTCTime end start)-- return ret-- -- | True if the object exists. exists :: ObjId -> Avers Bool-exists objId = trace "exists" $+exists objId = measureDuration M_avers_storage_exists_duration $ existsDocument objectsTable (BaseObjectId objId) -- | Lookup an 'Object' by its 'ObjId'. Throws 'ObjectNotFound' if the object -- doesn't exist. lookupObject :: ObjId -> Avers Object-lookupObject objId = trace "lookupObject" $ do+lookupObject objId = measureDuration M_avers_storage_lookupObject_duration $ do mbObject <- lookupDocument objectsTable (BaseObjectId objId) requireResult (ObjectNotFound objId) mbObject @@ -194,7 +182,7 @@ -- | Get the snapshot of the newest revision of the given object. lookupLatestSnapshot :: ObjectId -> Avers Snapshot-lookupLatestSnapshot objId = trace "lookupLatestSnapshot" $ do+lookupLatestSnapshot objId = measureDuration M_avers_storage_lookupLatestSnapshot_duration $ do snapshot <- newestSnapshot objId patches <- patchesAfterRevision objId (snapshotRevisionId snapshot) applyPatches snapshot patches@@ -239,7 +227,7 @@ -- use 'lookupLatestSnapshot'. newestSnapshot :: ObjectId -> Avers Snapshot-newestSnapshot objId = trace "newestSnapshot" $ do+newestSnapshot objId = measureDuration M_avers_storage_newestSnapshot_duration $ do (RevId revId) <- fromMaybe zeroRevId <$> lookupRecentRevision objId snapshot <- runQueryDatum $ headE $ R.OrderByIndexed (R.Descending "objectSnapshotSequence") $@@ -256,7 +244,7 @@ lookupSnapshot :: ObjectId -> RevId -> Avers Snapshot-lookupSnapshot objId (RevId revId) = trace "lookupSnapshot" $ do+lookupSnapshot objId (RevId revId) = measureDuration M_avers_storage_lookupSnapshot_duration $ do snapshot <- runQueryDatum $ headE $ R.OrderByIndexed (R.Descending "objectSnapshotSequence") $ R.BetweenIndexed "objectSnapshotSequence" (lowerBound, upperBound) $@@ -330,7 +318,7 @@ patchesAfterRevision :: ObjectId -> RevId -> Avers [Patch]-patchesAfterRevision objId (RevId revId) = trace "patchesAfterRevision" $ do+patchesAfterRevision objId (RevId revId) = measureDuration M_avers_storage_patchesAfterRevision_duration $ do res <- runQuery $ R.OrderBy [R.Ascending "revisionId"] $ R.BetweenIndexed "objectPatchSequence" (lowerBound, upperBound) $@@ -344,7 +332,7 @@ lookupPatch :: ObjectId -> RevId -> Avers Patch-lookupPatch objId revId = trace "lookupPatch" $ do+lookupPatch objId revId = measureDuration M_avers_storage_lookupPatch_duration $ do runQuerySingleSelection $ R.Get patchesTable $ R.lift $ toPk objId <> "@" <> toPk revId @@ -368,7 +356,7 @@ -> Bool -- ^ True if validation should be skipped -> Avers ([Patch], Int, [Patch]) -applyObjectUpdates objId revId committerId ops novalidate = trace "applyObjectUpdates" $ do+applyObjectUpdates objId revId committerId ops novalidate = measureDuration M_avers_storage_applyObjectUpdates_duration $ do -- First check that the object exists. We'll need its metadata later. obj <- lookupObject baseObjId SomeObjectType ot <- lookupObjectType (objectType obj)@@ -379,6 +367,12 @@ -- If there are any patches which the client doesn't know about we need -- to let her know. previousPatches <- patchesAfterRevision objId revId++ reportMeasurement M_avers_storage_applyObjectUpdates_numOperations+ (fromIntegral $ length ops)++ reportMeasurement M_avers_storage_applyObjectUpdates_numPreviousPatches+ (fromIntegral $ length previousPatches) latestSnapshot <- applyPatches baseSnapshot previousPatches
src/Avers/Types.hs view
@@ -37,12 +37,11 @@ import qualified Database.RethinkDB as R import Database.RethinkDB.TH -import qualified Database.InfluxDB as InfluxDB- import Data.Pool import Avers.TH import Avers.Index+import Avers.Metrics.Measurements @@ -510,9 +509,6 @@ -- ^ RethinkDB supports multiple databases. This is the name of the one -- which should be used. - , influxConfig :: !(Maybe InfluxDB.Config)- -- ^ The influx server where avers reports metrics to.- , putBlob :: BlobId -> Text -> ByteString -> IO () -- ^ Function which saves the given blob in the blob store. This can be -- the local filesystem or an external services such as Amazon S3.@@ -521,6 +517,10 @@ , objectTypes :: ![SomeObjectType] -- ^ All the object types which Avers knows about.++ , emitMeasurement :: Measurement -> Double -> IO ()+ -- ^ This is called when the internal instrumentation code creates+ -- a measurement. }
+ test/Test.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Hspec+import Control.Exception (evaluate)++import Data.Aeson as A+import Data.Aeson.Types+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HMS++import Avers+import Avers.Types (PatchM)+import Avers.Patching++isFailure :: PatchM a -> Bool+isFailure (Left _) = True+isFailure (Right _) = False++isSuccess :: PatchM a -> Bool+isSuccess (Left _) = False+isSuccess (Right _) = True++main :: IO ()+main = hspec spec++objA :: A.Value+objA = A.Object $ HMS.fromList [("id", A.String "foo"),("bar", A.String "baz")]++spec :: Spec+spec = parallel $ do++ describe "resolvePathIn" $ do+ it "should return the value if the path is empty" $ do+ resolvePathIn "" Null `shouldBe` Just Null++ it "should return Nothing if the value is not a container" $ do+ resolvePathIn "x" Null `shouldBe` Nothing+ resolvePathIn "x" (String "") `shouldBe` Nothing+ resolvePathIn "x" (Number 1) `shouldBe` Nothing+ resolvePathIn "x" (Bool True) `shouldBe` Nothing++ it "should return Nothing if the path can't be resolved" $ do+ resolvePathIn "foo" emptyObject `shouldBe` Nothing++ it "should return object field if the path points into an object" $ do+ resolvePathIn "bar" objA `shouldBe` Just (A.String "baz")++ it "should pick the item from an array which has the given id" $ do+ resolvePathIn "foo.bar" (Array $ V.fromList []) `shouldBe` Nothing+ resolvePathIn "foo.bar" (Array $ V.fromList [emptyObject]) `shouldBe` Nothing+ resolvePathIn "foo.bar" (Array $ V.fromList [objA]) `shouldBe` Just (A.String "baz")+++ describe "applyOperation" $ do+ it "should fail if it can't descend to the target value" $ do+ applyOperation emptyObject (Set "foo.bar.baz" Nothing) `shouldSatisfy` isFailure+ applyOperation emptyArray (Set "foo.bar.baz" Nothing) `shouldSatisfy` isFailure++ applyOperation emptyObject (Splice "foo.bar.baz" 0 0 []) `shouldSatisfy` isFailure+ applyOperation emptyArray (Splice "foo.bar.baz" 0 0 []) `shouldSatisfy` isFailure++ describe "Splice" $ do+ it "should handle primitive arrays" $ do+ let Right obj = applyOperation emptyObject (Set "array" (Just emptyArray))+ applyOperation obj (Splice "array" 0 0 ["elem"]) `shouldSatisfy` isSuccess++ it "should fail if the array doesn't match structure" $ do+ let Right obj = applyOperation emptyObject (Set "array" (Just $ Array $ V.singleton emptyObject))+ applyOperation obj (Splice "array" 0 0 ["elem"]) `shouldSatisfy` isFailure++ it "should fail if the array indices are out of range" $ do+ let Right obj = applyOperation emptyObject (Set "array" (Just emptyArray))+ applyOperation obj (Splice "array" 0 1 ["elem"]) `shouldSatisfy` isFailure++ describe "Set" $ do+ it "should create a new key if the key doesn't exist yet" $ do+ let (Right a) = applyOperation emptyObject $ Set "foo" (Just Null)+ resolvePathIn "foo" a `shouldBe` Just Null