avers 0.0.9 → 0.0.10

raw patch · 7 files changed

+164/−68 lines, 7 filesdep ~rethinkdb-client-driverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: rethinkdb-client-driver

API changes (from Hackage documentation)

Files

• avers.cabal +4/−4
• src/Avers.hs +4/−0
• src/Avers/Patching.hs +5/−3
• src/Avers/Storage.hs +90/−58
• src/Avers/Storage/Expressions.hs +43/−2
• src/Avers/Types.hs +15/−1
• test/Test.hs +3/−0

@@ -1,5 +1,5 @@ name:                avers-version:             0.0.9+version:             0.0.10 license:             GPL-3 license-file:        LICENSE author:              Tomas Carnecky@@ -72,7 +72,7 @@       , cryptohash       , inflections       , resource-pool-      , rethinkdb-client-driver >= 0.0.19+      , rethinkdb-client-driver == 0.0.20       , scrypt  @@ -93,7 +93,7 @@       , mtl       , criterion       , resource-pool-      , rethinkdb-client-driver >= 0.0.19+      , rethinkdb-client-driver == 0.0.20       , network-uri       , text @@ -119,7 +119,7 @@       , inflections       , mtl       , resource-pool-      , rethinkdb-client-driver >= 0.0.19+      , rethinkdb-client-driver == 0.0.20       , scrypt       , stm       , text

@@ -30,6 +30,9 @@   , objectsOfType   , allObjectsOfType +  , createCheckpoint+  , vacuumObject+     -- * Patch   , Patch(..)   , PatchError(..)@@ -112,6 +115,7 @@  import Avers.Patching import Avers.Storage+import Avers.Storage.Expressions import Avers.Storage.Backend import Avers.Types import Avers.Views

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards   #-}  module Avers.Patching     ( applyOperation@@ -28,8 +28,10 @@ -- | Apply the given op on the value. Can throw an exception if the operation --   is invalid. applyOperation :: Value -> Operation -> PatchM Value-applyOperation value Set{..} = changeObject value opPath $ \key ->-    maybe (M.delete key) (M.insert key) opValue+applyOperation value Set{..}+    | opPath == "", Just val <- opValue = return val+    | otherwise = changeObject value opPath $ \key ->+        maybe (M.delete key) (M.insert key) opValue  applyOperation value Splice{..} = changeArray value opPath $ \a -> do 

@@ -67,16 +67,7 @@ requireResult _   (Just v) = return v  --- All the tables which this storage engine uses.-objectsTable, sessionsTable, snapshotsTable, patchesTable, secretsTable, blobsTable :: R.Exp R.Table-blobsTable     = R.Table Nothing $ R.lift ("blobs" :: Text)-objectsTable   = R.Table Nothing $ R.lift ("objects" :: Text)-patchesTable   = R.Table Nothing $ R.lift ("patches" :: Text)-secretsTable   = R.Table Nothing $ R.lift ("secrets" :: Text)-sessionsTable  = R.Table Nothing $ R.lift ("sessions" :: Text)-snapshotsTable = R.Table Nothing $ R.lift ("snapshots" :: Text) - -- | True if the object exists. exists :: ObjId -> Avers Bool exists objId = measureDuration M_avers_storage_exists_duration $@@ -108,13 +99,15 @@ createObject' :: (ToJSON a) => ObjId -> UTCTime -> ObjectType a -> ObjId -> a -> Avers () createObject' objId now ot@ObjectType{..} createdBy content = do     insertDocument objectsTable object-    insertDocument snapshotsTable snapshot+    insertDocument patchesTable patch+     updateObjectViews ot objId (Just content)    where-    object   = Object objId otType now createdBy Nothing-    boId     = BaseObjectId objId-    snapshot = Snapshot boId zeroRevId (toJSON content)+    object = Object objId otType now createdBy Nothing+    boId   = BaseObjectId objId+    op     = Set rootPath (Just $ toJSON content)+    patch  = Patch boId zeroRevId objId now op   @@ -132,6 +125,8 @@ -- | Prune the object from the database. This is only allowed if the object is -- marked as deleted. Note that this is a very dangerous operation, it can not -- be undone.+--+-- TODO: Prune related Release and Authoriation objects. pruneObject :: ObjId -> Avers () pruneObject objId = do     obj <- lookupObject objId@@ -140,22 +135,11 @@     unless (objectDeleted obj == Just True) $         strErr $ "pruneObject: object " ++ show objId ++ " is not deleted" -    -- Drop all related patches. Note that there will never be a patch with-    -- revision zero, so it's safe to use 'patchesAfterRevision'.-    patches <- patchesAfterRevision (BaseObjectId objId) zeroRevId-    void $ mapM (deleteDocument patchesTable) patches--    -- Drop all related snapshots.-    snapshotDatums <- runQueryCollect $-        R.BetweenIndexed-            "objectSnapshotSequence"-            ( R.Closed $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral (0 :: Int)]-            , R.Open $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral (99999999 :: Int)]-            )--        snapshotsTable-    snapshots <- V.mapM parseDatum snapshotDatums :: Avers (Vector Snapshot)-    void $ V.mapM (deleteDocument snapshotsTable) snapshots+    -- Drop all base object patches and snapshots.+    void $ runQuery $ R.Delete $+        objectPatchSequenceE (BaseObjectId objId) 0 maxBound+    void $ runQuery $ R.Delete $+        objectSnapshotSequenceE (BaseObjectId objId) 0 maxBound      -- Remove related entries from all views.     forM_ (otViews objType) $ \(SomeView view) -> do@@ -166,6 +150,60 @@   +-- | Create a checkpoint for for the given object. All patches (and of course+-- snapshots) before the checkpoint can be dropped. Use 'vacuumObject' to do+-- that.+createCheckpoint :: ObjectId -> ObjId -> Avers RevId+createCheckpoint objId createdBy = do+    now <- liftIO $ getCurrentTime+    Snapshot{..} <- lookupLatestSnapshot objId++    let op    = Set rootPath (Just $ toJSON snapshotContent)+        revId = succ snapshotRevisionId++    savePatch $ Patch objId revId createdBy now op+    saveSnapshot $ Snapshot snapshotObjectId revId snapshotContent++    return revId++++isCheckpointPatch :: Patch -> Bool+isCheckpointPatch Patch{..} = case patchOperation of+    Set{..} -> opPath == rootPath+    _       -> False+++-- This function is rather inefficient when the object has many patches,+-- because it fetches *all* patches to the client and does the search in+-- Haskell. A more efficient version would filter the patches on the server.+latestCheckpointPatch :: ObjectId -> Avers (Maybe Patch)+latestCheckpointPatch objId = do+    patches <- objectPatches objId+    return $ find isCheckpointPatch (reverse patches)++++-- | Drop all patches and snapshots before the most recent checkpoint. This+-- effectively drops the object's history, and frees space in the database.+vacuumObject :: ObjectId -> Avers ()+vacuumObject objId = do+    mbPatch <- latestCheckpointPatch objId+    case mbPatch of+        Nothing -> return ()+        Just Patch{..} -> do+            -- This is the revision up to which we can drop snapshots and+            -- patches.+            let revId = unRevId patchRevisionId - 1++            -- Delete all snapshots and patches before the checkpoint.+            void $ runQuery $ R.Delete $+                objectSnapshotSequenceE objId 0 revId+            void $ runQuery $ R.Delete $+                objectPatchSequenceE objId 0 revId+++ ----------------------------------------------------------------------------- -- | Fetch the content of the object and try to parse it. --@@ -217,8 +255,22 @@         M.insertWith max objId revId  +-- | Lookup the latest snapshot within the given range. The bounds are+-- inclusive.+latestSnapshotBetween :: ObjectId -> Int -> Int -> Avers Snapshot+latestSnapshotBetween objId lo hi = do+    snapshots <- runQueryCollect $ limitE 1 $+        R.OrderByIndexed (R.Descending "objectSnapshotSequence") $+        objectSnapshotSequenceE objId lo hi +    snapshot <- case V.headM snapshots of+        Just x  -> parseDatum x+        Nothing -> return $ initialSnapshot objId +    updateRecentRevision objId (snapshotRevisionId snapshot)+    return snapshot++ ----------------------------------------------------------------------------- -- | Get the newest snapshot which is stored in the database. The object may -- be at a higher revision if the later snapshots are missing from the@@ -230,40 +282,23 @@ newestSnapshot :: ObjectId -> Avers Snapshot newestSnapshot objId = measureDuration M_avers_storage_newestSnapshot_duration $ do     (RevId revId) <- fromMaybe zeroRevId <$> lookupRecentRevision objId-    snapshot <- runQueryDatum $ headE $-        R.OrderByIndexed (R.Descending "objectSnapshotSequence") $-        R.BetweenIndexed "objectSnapshotSequence" ((lowerBound revId), upperBound) $-        snapshotsTable--    updateRecentRevision objId (snapshotRevisionId snapshot)-    return snapshot--  where-    lowerBound revId = R.Closed $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral revId]-    upperBound = R.Open $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral (99999999 :: Int)]-+    latestSnapshotBetween objId revId maxBound  +-- | Lookup the snapshot at a particular revision. lookupSnapshot :: ObjectId -> RevId -> Avers Snapshot lookupSnapshot objId (RevId revId) = measureDuration M_avers_storage_lookupSnapshot_duration $ do-    snapshot <- runQueryDatum $ headE $-        R.OrderByIndexed (R.Descending "objectSnapshotSequence") $-        R.BetweenIndexed "objectSnapshotSequence" (lowerBound, upperBound) $-        snapshotsTable+    snapshot <- latestSnapshotBetween objId 0 revId      -- Get all patches which we need to apply on top of the snapshot to     -- arrive at the desired revision.-    patches0 <- patchesAfterRevision objId (snapshotRevisionId snapshot)-    let patches = filter (\Patch{..} -> patchRevisionId <= RevId revId) patches0+    patches <- patchesAfterRevision objId (snapshotRevisionId snapshot) +    -- Apply those patches to the snapshot.     foldM applyPatchToSnapshot snapshot patches -  where-    lowerBound = R.Closed $ R.Array $ V.fromList [R.String $ toPk objId, R.Number 0]-    upperBound = R.Closed $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral revId]  - savePatch :: Patch -> Avers () savePatch = insertDocument patchesTable @@ -316,20 +351,17 @@    upsertDocument secretsTable $ Secret secId $ T.decodeUtf8 x  +objectPatches :: ObjectId -> Avers [Patch]+objectPatches objId = patchesAfterRevision objId (RevId (-1))   patchesAfterRevision :: ObjectId -> RevId -> Avers [Patch] patchesAfterRevision objId (RevId revId) = measureDuration M_avers_storage_patchesAfterRevision_duration $ do-    res <- runQuery $+    res <- runQueryCollect $         R.OrderBy [R.Ascending "revisionId"] $-        R.BetweenIndexed "objectPatchSequence" (lowerBound, upperBound) $-        patchesTable+        objectPatchSequenceE objId revId maxBound      V.toList <$> V.mapM parseDatum res--  where-    lowerBound = R.Open $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral revId]-    upperBound = R.Open $ R.Array $ V.fromList [R.String $ toPk objId, R.Number $ fromIntegral (revId + 999999)]   lookupPatch :: ObjectId -> RevId -> Avers Patch

@@ -14,12 +14,27 @@ module Avers.Storage.Expressions where  -import           Prelude hiding (lookup)+import qualified Data.Vector        as V  import           Data.Text (Text) import           Database.RethinkDB as R +import           Avers.Types hiding (Object) +import           Prelude hiding (lookup)++++-- All the tables which this storage engine uses.+objectsTable, sessionsTable, snapshotsTable, patchesTable, secretsTable, blobsTable :: Exp Table+blobsTable     = Table Nothing $ lift ("blobs" :: Text)+objectsTable   = Table Nothing $ lift ("objects" :: Text)+patchesTable   = Table Nothing $ lift ("patches" :: Text)+secretsTable   = Table Nothing $ lift ("secrets" :: Text)+sessionsTable  = Table Nothing $ lift ("sessions" :: Text)+snapshotsTable = Table Nothing $ lift ("snapshots" :: Text)++ -- | The primary key in all our documents is the default "id". primaryKeyField :: Text primaryKeyField = "id"@@ -47,6 +62,32 @@ primaryKeyEqE = objectFieldEqE primaryKeyField  --- | Take the first item out of a sequence.+-- | Take the first item out of a sequence. Beware that this throws an error+-- when the sequence is empty. headE :: (IsSequence a, IsDatum r) => Exp a -> Exp r headE = Nth 0+++-- | Limit a sequence to the first 'n' items.+limitE :: (IsSequence s) => Int -> Exp s -> Exp s+limitE n s = Limit (fromIntegral n) s+++mkBounds :: ObjectId -> Int -> Int -> (Bound, Bound)+mkBounds objId lo hi = (mkBound objId lo, mkBound objId hi)++mkBound :: ObjectId -> Int -> Bound+mkBound objId revId = Closed $ Array $ V.fromList+    [String $ toPk objId, Number $ fromIntegral revId]+++objectSnapshotSequenceE :: ObjectId -> Int -> Int -> Exp Table+objectSnapshotSequenceE objId lo hi =+    BetweenIndexed "objectSnapshotSequence" (mkBounds objId lo hi) $+    snapshotsTable+++objectPatchSequenceE :: ObjectId -> Int -> Int -> Exp Table+objectPatchSequenceE objId lo hi =+    BetweenIndexed "objectPatchSequence" (mkBounds objId lo hi) $+    patchesTable

@@ -86,7 +86,13 @@     toDatum = R.toDatum . unPath  +-- | This path refers to the root of an object. It is only used in 'Set'+-- operations.+rootPath :: Path+rootPath = Path "" ++ ----------------------------------------------------------------------------- -- | ObjId @@ -302,7 +308,12 @@ $(deriveEncoding (deriveJSONOptions "snapshot") ''Snapshot)  +-- | The initial snapshot on top of which all future patches are applied.+initialSnapshot :: ObjectId -> Snapshot+initialSnapshot objId = Snapshot objId (RevId (-1)) Aeson.emptyObject ++ ----------------------------------------------------------------------------- -- | Release @@ -534,7 +545,9 @@ databasePort :: Config -> Int databasePort Config{..} = fromMaybe R.defaultPort $ do     auth <- uriAuthority databaseURI-    readMay $ uriPort auth+    case uriPort auth of+        []  -> Nothing+        _:x -> readMay x  databaseAuth :: Config -> Maybe Text databaseAuth Config{..} = do@@ -575,6 +588,7 @@         putStrLn $ mconcat             [ "Creating a new RethinkDB handle to "             , T.unpack host+            , ":"             , show port             , " database "             , T.unpack db

@@ -75,6 +75,9 @@                 applyOperation obj (Splice "array" 0 1 ["elem"]) `shouldSatisfy` isFailure          describe "Set" $ do+            it "should replace the whole object if path is the root" $ do+                let (Right a) = applyOperation emptyObject $ Set "" (Just objA)+                a `shouldBe` objA             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