diff --git a/avers.cabal b/avers.cabal --- a/avers.cabal +++ b/avers.cabal @@ -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 diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark.hs @@ -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 diff --git a/src/Avers.hs b/src/Avers.hs --- a/src/Avers.hs +++ b/src/Avers.hs @@ -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 diff --git a/src/Avers/Metrics.hs b/src/Avers/Metrics.hs --- a/src/Avers/Metrics.hs +++ b/src/Avers/Metrics.hs @@ -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 diff --git a/src/Avers/Metrics/Measurements.hs b/src/Avers/Metrics/Measurements.hs new file mode 100644 --- /dev/null +++ b/src/Avers/Metrics/Measurements.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Avers.Metrics.Measurements (Measurement(..), measurementLabels) where + +import Avers.Metrics.TH +mkMeasurements diff --git a/src/Avers/Storage.hs b/src/Avers/Storage.hs --- a/src/Avers/Storage.hs +++ b/src/Avers/Storage.hs @@ -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 diff --git a/src/Avers/Types.hs b/src/Avers/Types.hs --- a/src/Avers/Types.hs +++ b/src/Avers/Types.hs @@ -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. } diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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