From 517ba2fe6228d7923e2ce674d43917ceecf0427c Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Wed, 21 Jun 2023 11:50:36 +0000 Subject: [PATCH 1/9] Fix fetchVCObjectHistory --- .../src/Inferno/VersionControl/Operations.hs | 135 +++++++----------- 1 file changed, 54 insertions(+), 81 deletions(-) diff --git a/inferno-vc/src/Inferno/VersionControl/Operations.hs b/inferno-vc/src/Inferno/VersionControl/Operations.hs index 65e46ee..1bf770f 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations.hs @@ -33,9 +33,9 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as BL +import Data.Foldable (foldrM) import Data.Generics.Product (HasType, getTyped) import Data.Generics.Sum (AsType (..)) -import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import Data.Text (pack) @@ -340,87 +340,60 @@ fetchVCObjectHistory h = do head_h <- fetchCurrentHead h let head_fp = storePath "heads" show head_h preds <- readVCObjectHashTxt head_fp - pure $ head_h : preds - -- When we fold the history, we check if they exist in two places - -- 1. in 'vc_store' for available scripts - -- 2. then in 'vc_store/removed' for scripts that have been deleted - -- If a script has been deleted, we track its hash. - -- Since objects can never be modified, only deleted, we don't need to hold a lock here - let f acc hsh = do - existsInRoot <- liftIO $ doesFileExist $ storePath show hsh - existsInRemoved <- liftIO $ doesFileExist $ storePath "removed" show hsh - - if existsInRoot - then do - obj <- fmap (const hsh) <$> fetchVCObject hsh - pure ((obj : fst acc), snd acc) - else do - if existsInRemoved - then do - obj <- fmap (const hsh) <$> fetchRemovedVCObject hsh - pure ((obj : fst acc), (hsh : snd acc)) - else -- This script no longer exists even in 'removed' directory. The directory might get cleaned up by accident or something. - -- There are two choices we can make, - -- 1. Return a `VCMeta VCObjectHash` with dummy data - -- 2. Ignore this meta. - -- Approach no. 2 is taken here by just returning the accumulator. - pure acc - (metas, removeds) <- foldM f ([], []) history - -- The rest of this function handles the case when this script history was obtained by - -- cloning, and adds the original script to the returned history, if it still exists: - case removeds of - [] -> - -- if it is a clone, we would like to prepend source of the cloned script as part of the history. - -- it is fine to only do this once since we only show the last source of the clone - -- i.e. original -> cloneof orignal = cloned -> cloneof cloned = cloned' - -- when viewing cloned' history, it will only show up to cloned. - case metas of - all'@(x : _) -> - case Inferno.VersionControl.Types.pred x of + -- Order: oldest to newest (lazy evaluation should mean this isn't expensive concatenation) + pure $ preds ++ [head_h] + -- The fold goes from right to left (newest to oldest), but the accumulator is reversed + -- so the result is oldest to newest: + foldrM getHistory [] history + where + -- Recurse through history, newest to oldest, and stop when we find a clone + getHistory hsh acc = do + getObj hsh >>= \case + Nothing -> pure acc + Just eObj -> do + -- Assuming either the entire history of a script is deleted, or none of it, + -- we only care about whether a script has been deleted when we look up the + -- source of a clone + let obj = either id id eObj + case Inferno.VersionControl.Types.pred obj of CloneOf hsh' -> do - existsInRoot <- liftIO $ doesFileExist $ storePath show hsh' - existsInRemoved <- liftIO $ doesFileExist $ storePath "removed" show hsh' - - if existsInRoot - then do - original <- fmap (const hsh') <$> fetchVCObject hsh' - -- 'nubBy' is needed for backward compatibility with current scripts. Clone scripts' head look like this, - -- - -- x_0 (init) - -- x_1 (clone) - -- x_1_1 - -- - -- However, for new script (anything after this PR landed,https://github.com/plow-technologies/all/pull/9801), - -- clone scripts' head are stored like this, - -- - -- x_1 (clone) - -- x_1_1 - -- - -- Note that it is missing the init object. When we fetch for histories, we look for pred of clone and add it to the history, but for existing scripts this means it adds init object twice - pure $ List.nubBy (\a b -> obj a == obj b) $ original : all' - else do - if existsInRemoved - then do - original <- fmap (const hsh') <$> fetchRemovedVCObject hsh' - pure $ List.nubBy (\a b -> obj a == obj b) $ original {Inferno.VersionControl.Types.pred = CloneOfRemoved hsh'} : all' - else pure all' - _ -> pure all' - _ -> pure metas - _ -> - pure $ - fmap - ( \meta -> case Inferno.VersionControl.Types.pred meta of - CloneOf hsh' - | List.elem hsh' removeds -> - -- The source of the clone script has been deleted, so we alter its 'pred' field as 'CloneOfRemoved' but - -- with the same hash. This way the upstream system (e.g. onping/frontend) can differentiate between - -- source that is still available and no longer available. - -- This does not change the way the script is persisted in the db, it is still stored as 'CloneOf'. - -- See 'CloneOfRemoved' for details. - meta {Inferno.VersionControl.Types.pred = CloneOfRemoved hsh'} - _ -> meta - ) - metas + -- if it is a clone, we would like to prepend source of the cloned script as part of the history. + -- it is fine to only do this once since we only show the last source of the clone + -- i.e. original -> cloneof orignal = cloned -> cloneof cloned = cloned' + -- when viewing cloned' history, it will only show up to cloned. + getObj hsh' >>= \case + Just (Right ori) -> + pure $ ori : obj : acc + Just (Left ori) -> + -- The source of the clone script has been deleted, so we alter its 'pred' field as 'CloneOfRemoved' but + -- with the same hash. This way the upstream system (e.g. onping/frontend) can differentiate between + -- source that is still available and no longer available. + -- This does not change the way the script is persisted in the db, it is still stored as 'CloneOf'. + -- See 'CloneOfRemoved' for details. + pure $ ori : obj {Inferno.VersionControl.Types.pred = CloneOfRemoved hsh'} : acc + Nothing -> + -- This script no longer exists even in 'removed' directory. The directory might get cleaned up by accident or something. + -- There are two choices we can make, + -- 1. Return a `VCMeta VCObjectHash` with dummy data + -- 2. Ignore this meta. + -- Approach no. 2 is taken here + pure $ obj : acc + _ -> pure $ obj : acc + + getObj hsh = do + VCStorePath storePath <- asks getTyped + existsInRoot <- liftIO $ doesFileExist $ storePath show hsh + if existsInRoot + then do + obj <- fmap (const hsh) <$> fetchVCObject hsh + pure $ Just $ Right obj + else do + existsInRemoved <- liftIO $ doesFileExist $ storePath "removed" show hsh + if existsInRemoved + then do + obj <- fmap (const hsh) <$> fetchRemovedVCObject hsh + pure $ Just $ Left obj + else pure Nothing getAllHeads :: (VCStoreLogM env m, VCStoreEnvM env m) => m [VCObjectHash] getAllHeads = do From 04b1bde16c30dcf19e824d1fc965d141260e4fad Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Thu, 22 Jun 2023 13:59:14 +0000 Subject: [PATCH 2/9] Use recursion with short-circuit instead of foldrM --- .../src/Inferno/VersionControl/Operations.hs | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/inferno-vc/src/Inferno/VersionControl/Operations.hs b/inferno-vc/src/Inferno/VersionControl/Operations.hs index 1bf770f..1597d98 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations.hs @@ -33,7 +33,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as BL -import Data.Foldable (foldrM) import Data.Generics.Product (HasType, getTyped) import Data.Generics.Sum (AsType (..)) import qualified Data.Map as Map @@ -340,16 +339,18 @@ fetchVCObjectHistory h = do head_h <- fetchCurrentHead h let head_fp = storePath "heads" show head_h preds <- readVCObjectHashTxt head_fp - -- Order: oldest to newest (lazy evaluation should mean this isn't expensive concatenation) - pure $ preds ++ [head_h] - -- The fold goes from right to left (newest to oldest), but the accumulator is reversed + -- Order: newest to oldest + pure $ head_h : reverse preds + -- We recruse through history newest to oldest, but the accumulator gets reversed -- so the result is oldest to newest: - foldrM getHistory [] history + res <- getHistory [] history + trace $ DeleteFile $ show $ map Inferno.VersionControl.Types.obj res + pure res where -- Recurse through history, newest to oldest, and stop when we find a clone - getHistory hsh acc = do + getHistory acc (hsh : history) = do getObj hsh >>= \case - Nothing -> pure acc + Nothing -> getHistory acc history Just eObj -> do -- Assuming either the entire history of a script is deleted, or none of it, -- we only care about whether a script has been deleted when we look up the @@ -377,8 +378,9 @@ fetchVCObjectHistory h = do -- 1. Return a `VCMeta VCObjectHash` with dummy data -- 2. Ignore this meta. -- Approach no. 2 is taken here - pure $ obj : acc - _ -> pure $ obj : acc + getHistory (obj : acc) history + _ -> getHistory (obj : acc) history + getHistory acc [] = pure acc getObj hsh = do VCStorePath storePath <- asks getTyped From f5be5abd3ca26e3f5d98b7e9ccfdd1eb5a49557f Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Mon, 26 Jun 2023 06:34:18 +0200 Subject: [PATCH 3/9] Use faster recursion without accumulator --- .../src/Inferno/VersionControl/Operations.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/inferno-vc/src/Inferno/VersionControl/Operations.hs b/inferno-vc/src/Inferno/VersionControl/Operations.hs index 1597d98..00cfab2 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations.hs @@ -341,16 +341,15 @@ fetchVCObjectHistory h = do preds <- readVCObjectHashTxt head_fp -- Order: newest to oldest pure $ head_h : reverse preds - -- We recruse through history newest to oldest, but the accumulator gets reversed - -- so the result is oldest to newest: - res <- getHistory [] history + -- We recruse through history newest to oldest, and return the history in the same order: + res <- getHistory history trace $ DeleteFile $ show $ map Inferno.VersionControl.Types.obj res pure res where -- Recurse through history, newest to oldest, and stop when we find a clone - getHistory acc (hsh : history) = do + getHistory (hsh : history) = do getObj hsh >>= \case - Nothing -> getHistory acc history + Nothing -> getHistory history -- TODO error? Just eObj -> do -- Assuming either the entire history of a script is deleted, or none of it, -- we only care about whether a script has been deleted when we look up the @@ -364,23 +363,24 @@ fetchVCObjectHistory h = do -- when viewing cloned' history, it will only show up to cloned. getObj hsh' >>= \case Just (Right ori) -> - pure $ ori : obj : acc + pure [obj, ori] Just (Left ori) -> -- The source of the clone script has been deleted, so we alter its 'pred' field as 'CloneOfRemoved' but -- with the same hash. This way the upstream system (e.g. onping/frontend) can differentiate between -- source that is still available and no longer available. -- This does not change the way the script is persisted in the db, it is still stored as 'CloneOf'. -- See 'CloneOfRemoved' for details. - pure $ ori : obj {Inferno.VersionControl.Types.pred = CloneOfRemoved hsh'} : acc + pure [obj {Inferno.VersionControl.Types.pred = CloneOfRemoved hsh'}, ori] Nothing -> -- This script no longer exists even in 'removed' directory. The directory might get cleaned up by accident or something. -- There are two choices we can make, -- 1. Return a `VCMeta VCObjectHash` with dummy data -- 2. Ignore this meta. -- Approach no. 2 is taken here - getHistory (obj : acc) history - _ -> getHistory (obj : acc) history - getHistory acc [] = pure acc + -- TODO error? + getHistory history >>= \res -> pure $ obj : res + _ -> getHistory history >>= \res -> pure $ obj : res + getHistory [] = pure [] getObj hsh = do VCStorePath storePath <- asks getTyped From 13c8fe13fa8aa2ddd5068d898b9c2d95c861321c Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Mon, 26 Jun 2023 06:44:05 +0200 Subject: [PATCH 4/9] Bump --- inferno-core/CHANGELOG.md | 3 +++ inferno-core/inferno-core.cabal | 4 ++-- inferno-lsp/CHANGELOG.md | 3 +++ inferno-lsp/inferno-lsp.cabal | 4 ++-- inferno-vc/CHANGELOG.md | 3 +++ inferno-vc/inferno-vc.cabal | 2 +- 6 files changed, 14 insertions(+), 5 deletions(-) diff --git a/inferno-core/CHANGELOG.md b/inferno-core/CHANGELOG.md index 27d7b82..80c1e99 100644 --- a/inferno-core/CHANGELOG.md +++ b/inferno-core/CHANGELOG.md @@ -1,6 +1,9 @@ # Revision History for inferno-core *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.3.1 -- 2023-06-26 +* Update inferno-vc version + ## 0.3.0 -- 2023-06-14 * Introduce Interpreter API to make Inferno parametric on types, values, and primitives diff --git a/inferno-core/inferno-core.cabal b/inferno-core/inferno-core.cabal index f3a42ab..1b4c111 100644 --- a/inferno-core/inferno-core.cabal +++ b/inferno-core/inferno-core.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: inferno-core -version: 0.3.0 +version: 0.3.1 synopsis: A statically-typed functional scripting language description: Parser, type inference, and interpreter for a statically-typed functional scripting language category: DSL,Scripting @@ -55,7 +55,7 @@ library , cryptonite >= 0.30 && < 0.31 , exceptions >= 0.10.4 && < 0.11 , generic-lens >= 2.2.1 && < 2.3 - , inferno-vc >= 0.2.0 && < 0.3 + , inferno-vc >= 0.3.0 && < 0.4 , inferno-types >= 0.1.0 && < 0.2 , megaparsec >= 9.2.1 && < 9.3 , memory >= 0.18.0 && < 0.19 diff --git a/inferno-lsp/CHANGELOG.md b/inferno-lsp/CHANGELOG.md index ca8b6ca..93c574b 100644 --- a/inferno-lsp/CHANGELOG.md +++ b/inferno-lsp/CHANGELOG.md @@ -1,6 +1,9 @@ # Revision History for inferno-lsp *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.1.5 -- 2023-06-26 +* Update inferno-vc version + ## 0.1.4 -- 2023-06-19 * Raise error if script evaluates to a function (and suggest adding input parameters instead) diff --git a/inferno-lsp/inferno-lsp.cabal b/inferno-lsp/inferno-lsp.cabal index aa15619..bf72c06 100644 --- a/inferno-lsp/inferno-lsp.cabal +++ b/inferno-lsp/inferno-lsp.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: inferno-lsp -version: 0.1.4 +version: 0.1.5 synopsis: LSP for Inferno description: A language server protocol implementation for the Inferno language category: IDE,DSL,Scripting @@ -35,7 +35,7 @@ library , exceptions >= 0.10.4 && < 0.11 , inferno-core >= 0.3.0 && < 0.4 , inferno-types >= 0.1.0 && < 0.2 - , inferno-vc >= 0.2.0 && < 0.3 + , inferno-vc >= 0.3.0 && < 0.4 , lsp >= 1.6.0 && < 1.7 , lsp-types >= 1.6.0 && < 1.7 , megaparsec >= 9.2.1 && < 9.3 diff --git a/inferno-vc/CHANGELOG.md b/inferno-vc/CHANGELOG.md index b913833..8010263 100644 --- a/inferno-vc/CHANGELOG.md +++ b/inferno-vc/CHANGELOG.md @@ -1,6 +1,9 @@ # Revision History for inferno-vc *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.3.0 -- 2023-06-26 +* Fix the order returned by `fetchVCObjectHistory`. BREAKING CHANGE: history is now returned in newest to oldest order. + ## 0.2.1 -- 2023-04-26 * Fixes an issue in `fetchVCObjectHistory` that occurred when deleting the source script immediately after cloning it diff --git a/inferno-vc/inferno-vc.cabal b/inferno-vc/inferno-vc.cabal index f81c39b..ca5190a 100644 --- a/inferno-vc/inferno-vc.cabal +++ b/inferno-vc/inferno-vc.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: inferno-vc -version: 0.2.1 +version: 0.3.0 synopsis: Version control server for Inferno description: A version control server for Inferno scripts category: DSL,Scripting From 43f6167a10bbff1e2f47aa9b11fae122aa800a81 Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Mon, 26 Jun 2023 07:33:44 +0200 Subject: [PATCH 5/9] Cleanup --- inferno-vc/src/Inferno/VersionControl/Operations.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/inferno-vc/src/Inferno/VersionControl/Operations.hs b/inferno-vc/src/Inferno/VersionControl/Operations.hs index 00cfab2..7c9bf6b 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations.hs @@ -342,14 +342,12 @@ fetchVCObjectHistory h = do -- Order: newest to oldest pure $ head_h : reverse preds -- We recruse through history newest to oldest, and return the history in the same order: - res <- getHistory history - trace $ DeleteFile $ show $ map Inferno.VersionControl.Types.obj res - pure res + getHistory history where -- Recurse through history, newest to oldest, and stop when we find a clone getHistory (hsh : history) = do getObj hsh >>= \case - Nothing -> getHistory history -- TODO error? + Nothing -> getHistory history Just eObj -> do -- Assuming either the entire history of a script is deleted, or none of it, -- we only care about whether a script has been deleted when we look up the @@ -377,7 +375,6 @@ fetchVCObjectHistory h = do -- 1. Return a `VCMeta VCObjectHash` with dummy data -- 2. Ignore this meta. -- Approach no. 2 is taken here - -- TODO error? getHistory history >>= \res -> pure $ obj : res _ -> getHistory history >>= \res -> pure $ obj : res getHistory [] = pure [] From e39a9382d7d1919cfee924f3084552a8eeb40523 Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Mon, 26 Jun 2023 20:20:26 +0200 Subject: [PATCH 6/9] Add tests for inferno-vc --- inferno-vc/inferno-vc.cabal | 30 +++++ inferno-vc/test/Spec.hs | 225 ++++++++++++++++++++++++++++++++++++ 2 files changed, 255 insertions(+) create mode 100644 inferno-vc/test/Spec.hs diff --git a/inferno-vc/inferno-vc.cabal b/inferno-vc/inferno-vc.cabal index ca5190a..4bc1d8e 100644 --- a/inferno-vc/inferno-vc.cabal +++ b/inferno-vc/inferno-vc.cabal @@ -76,6 +76,36 @@ library , TupleSections , RecordWildCards +test-suite inferno-vc-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base >=4.7 && <5 + , containers + , ghc + , hspec + , http-client + , inferno-types + , inferno-vc + , QuickCheck + , servant-client + , servant-server + , servant-typed-error + , time + default-language: Haskell2010 + default-extensions: + DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , FlexibleContexts + , FlexibleInstances + , LambdaCase + , OverloadedStrings + , TupleSections + , RecordWildCards + ghc-options: -Wall -Wunused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded + -- An example executable definition, needs instantation of author/group types: -- executable inferno-vc-server -- main-is: Main.hs diff --git a/inferno-vc/test/Spec.hs b/inferno-vc/test/Spec.hs new file mode 100644 index 0000000..8c4041e --- /dev/null +++ b/inferno-vc/test/Spec.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Main (main) where + +import Control.Concurrent (forkIO) +import Control.Monad (forM_) +import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) +import qualified Data.Set as Set +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Foreign.C (CTime (..)) +import GHC.Utils.TmpFs (withSystemTempDirectory) +import Inferno.Types.Syntax (Expr (Lit), Lit (LDouble), TV (TV)) +import Inferno.Types.Type (ImplType (ImplType), TCScheme (ForallTC), typeDouble) +import Inferno.VersionControl.Client (ClientMWithVCStoreError, api, mkVCClientEnv) +import Inferno.VersionControl.Operations.Error (VCStoreError (..)) +import Inferno.VersionControl.Server (VCServerError (VCServerError), runServerConfig) +import Inferno.VersionControl.Server.Types (ServerConfig (..)) +import Inferno.VersionControl.Types (Pinned, VCMeta (..), VCObject (VCFunction), VCObjectHash, VCObjectPred (CloneOf, Init, MarkedBreakingWithPred), VCObjectVisibility (VCObjectPublic)) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Servant ((:<|>) (..)) +import Servant.Client (BaseUrl (..), ClientEnv, Scheme (..), client) +import Servant.Typed.Error (runTypedClientM, typedClient) +import Test.Hspec +import Test.QuickCheck (arbitrary, generate) + +fetchFunction :: VCObjectHash -> ClientMWithVCStoreError (VCMeta Int Int (Expr (Pinned VCObjectHash) (), TCScheme)) +fetchFunctionsForGroups :: Set.Set Int -> ClientMWithVCStoreError [VCMeta Int Int VCObjectHash] +fetchVCObject :: VCObjectHash -> ClientMWithVCStoreError (VCMeta Int Int VCObject) +fetchVCObjectHistory :: VCObjectHash -> ClientMWithVCStoreError [VCMeta Int Int VCObjectHash] +fetchVCObjects :: [VCObjectHash] -> ClientMWithVCStoreError (Map.Map VCObjectHash (VCMeta Int Int VCObject)) +fetchVCObjectClosureHashes :: VCObjectHash -> ClientMWithVCStoreError [VCObjectHash] +pushFunction :: VCMeta Int Int (Expr (Pinned VCObjectHash) (), TCScheme) -> ClientMWithVCStoreError VCObjectHash +deleteAutosavedFunction :: VCObjectHash -> ClientMWithVCStoreError () +deleteVCObject :: VCObjectHash -> ClientMWithVCStoreError () +fetchFunction + :<|> fetchFunctionsForGroups + :<|> fetchVCObject + :<|> fetchVCObjectHistory + :<|> fetchVCObjects + :<|> fetchVCObjectClosureHashes + :<|> pushFunction + :<|> deleteAutosavedFunction + :<|> deleteVCObject = typedClient $ client $ api @Int @Int + +runOperation :: ClientEnv -> ClientMWithVCStoreError a -> (a -> IO ()) -> IO () +runOperation vcClientEnv op check = do + (flip runTypedClientM vcClientEnv op) >>= \case + Left err -> do + expectationFailure $ show err + Right res -> do + check res + +runOperationFail :: (Show a) => ClientEnv -> ClientMWithVCStoreError a -> (VCServerError -> IO ()) -> IO () +runOperationFail vcClientEnv op check = do + (flip runTypedClientM vcClientEnv op) >>= \case + Left (Right err) -> do + check err + Left (Left err) -> do + expectationFailure $ "Expected VCServerError but failed with " <> show err + Right res -> do + expectationFailure $ "Expected this operation to fail but it returned " <> show res + +createObj :: VCObjectPred -> IO (VCMeta Int Int (Expr (Pinned VCObjectHash) (), TCScheme)) +createObj predecessor = do + ctime <- CTime . round . toRational . utcTimeToPOSIXSeconds <$> getCurrentTime + d <- generate arbitrary + pure + VCMeta + { timestamp = ctime, + author = 432, + group = 432, + name = "Test", + description = "", + Inferno.VersionControl.Types.pred = predecessor, + visibility = VCObjectPublic, + obj = (Lit () (LDouble d), ForallTC [TV 0] mempty $ ImplType mempty $ typeDouble) + } + +spec :: ClientEnv -> Spec +spec vcClientEnv = + describe "inferno-vc server" $ do + it "basics" $ do + o1 <- createObj Init + runOperation vcClientEnv (pushFunction o1) $ \h1 -> do + o2 <- createObj $ MarkedBreakingWithPred h1 + runOperation vcClientEnv (pushFunction o2) $ \h2 -> do + o3 <- createObj $ MarkedBreakingWithPred h2 + runOperation vcClientEnv (pushFunction o3) $ \h3 -> do + o4 <- createObj $ MarkedBreakingWithPred h3 + runOperation vcClientEnv (pushFunction o4) $ \h4 -> do + -- Test fetchFunction: + forM_ [(o1, h1), (o2, h2), (o3, h3), (o4, h4)] $ \(o, h) -> + runOperation vcClientEnv (fetchFunction h) $ \o' -> do + timestamp o' `shouldBe` timestamp o + obj o' `shouldBe` obj o + + -- Test fetchVCObject: + forM_ [(o1, h1), (o2, h2), (o3, h3), (o4, h4)] $ \(o, h) -> + runOperation vcClientEnv (fetchVCObject h) $ \o' -> + case obj o' of + VCFunction e t -> do + timestamp o' `shouldBe` timestamp o + (e, t) `shouldBe` (obj o) + _ -> expectationFailure "Expected to get a VCFunction" + + -- Test fetchVCObjects: + runOperation vcClientEnv (fetchVCObjects [h1, h3, h4]) $ \hashToMeta -> do + Set.fromList (Map.keys hashToMeta) `shouldBe` Set.fromList [h1, h3, h4] + forM_ [(o1, h1), (o3, h3), (o4, h4)] $ \(o, h) -> + case Map.lookup h hashToMeta of + Just meta -> + timestamp meta `shouldBe` timestamp o + Nothing -> expectationFailure "impossible" + + -- fetchFunctionsForGroups only returns the head h4: + runOperation vcClientEnv (fetchFunctionsForGroups (Set.singleton 432)) $ \metas -> do + map obj metas `shouldBe` [h4] + + -- The closure of h4 should be empty as it has no dependencies: + runOperation vcClientEnv (fetchVCObjectClosureHashes h4) $ \metas -> do + metas `shouldBe` [] + + it "deletion" $ do + o1 <- createObj Init + runOperation vcClientEnv (pushFunction o1) $ \h1 -> do + o2 <- createObj Init + runOperation vcClientEnv (pushFunction o2) $ \h2 -> do + o3 <- createObj Init + runOperation vcClientEnv (pushFunction o3) $ \h3 -> do + o4 <- createObj Init + runOperation vcClientEnv (pushFunction o4) $ \h4 -> do + runOperation vcClientEnv (deleteVCObject h3) $ \() -> do + -- Fetching h3 should fail: + runOperationFail vcClientEnv (fetchFunction h3) $ \case + VCServerError (CouldNotFindPath _) -> pure () + _ -> expectationFailure "" + -- Others should fetch: + forM_ [(o1, h1), (o2, h2), (o4, h4)] $ \(o, h) -> + runOperation vcClientEnv (fetchFunction h) $ \o' -> do + timestamp o' `shouldBe` timestamp o + obj o' `shouldBe` obj o + + -- -- TODO is fetchFunctionsForGRoups wrong? It is returning deleted scripts: + -- runOperation vcClientEnv (fetchFunctionsForGroups (Set.singleton 432)) $ \metas -> do + -- Set.fromList (map obj metas) `shouldBe` Set.fromList [h4, h2, h1] + + it "deletion of autosave" $ do + o1 <- createObj Init + runOperation vcClientEnv (pushFunction o1) $ \h1 -> do + o2 <- createObj Init + runOperation vcClientEnv (pushFunction (o2 {name = ""})) $ \h2 -> do + -- h1 isn't an autosave so can't delete it: + runOperationFail vcClientEnv (deleteAutosavedFunction h1) $ \case + VCServerError (TryingToDeleteNonAutosave _) -> pure () + _ -> expectationFailure "" + -- h2 is an autosave so it's fine + runOperation vcClientEnv (deleteAutosavedFunction h2) $ \() -> pure () + + it "history" $ do + o1 <- createObj Init + runOperation vcClientEnv (pushFunction o1) $ \h1 -> do + o2 <- createObj $ MarkedBreakingWithPred h1 + runOperation vcClientEnv (pushFunction o2) $ \h2 -> do + o3 <- createObj $ MarkedBreakingWithPred h2 + runOperation vcClientEnv (pushFunction o3) $ \h3 -> do + o4 <- createObj $ MarkedBreakingWithPred h3 + runOperation vcClientEnv (pushFunction o4) $ \h4 -> do + runOperation vcClientEnv (fetchVCObjectHistory h4) $ \metas -> + (map obj metas) `shouldBe` [h4, h3, h2, h1] + + it "history of clone" $ do + o1 <- createObj Init + runOperation vcClientEnv (pushFunction o1) $ \h1 -> do + o2 <- createObj $ MarkedBreakingWithPred h1 + runOperation vcClientEnv (pushFunction o2) $ \h2 -> do + o3 <- createObj $ CloneOf h2 + runOperation vcClientEnv (pushFunction o3) $ \h3 -> do + o4 <- createObj $ MarkedBreakingWithPred h3 + runOperation vcClientEnv (pushFunction o4) $ \h4 -> do + runOperation vcClientEnv (fetchVCObjectHistory h4) $ \metas -> + (map obj metas) `shouldBe` [h4, h3, h2] + + it "history of clone of clone" $ do + o1 <- createObj Init + runOperation vcClientEnv (pushFunction o1) $ \h1 -> do + o2 <- createObj $ CloneOf h1 + runOperation vcClientEnv (pushFunction o2) $ \h2 -> do + o3 <- createObj $ CloneOf h2 + runOperation vcClientEnv (pushFunction o3) $ \h3 -> do + o4 <- createObj $ MarkedBreakingWithPred h3 + runOperation vcClientEnv (pushFunction o4) $ \h4 -> do + runOperation vcClientEnv (fetchVCObjectHistory h4) $ \metas -> + (map obj metas) `shouldBe` [h4, h3, h2] + +main :: IO () +main = + withSystemTempDirectory "vc_store_" $ \vcPath -> do + putStrLn $ "Store is at: " ++ (show vcPath) + + putStr "Starting Inferno VC..." + _ <- + forkIO $ + runServerConfig + (Proxy :: Proxy Int) + (Proxy :: Proxy Int) + ServerConfig + { _serverHost = "127.0.0.1", + _serverPort = 13077, + _vcPath = vcPath + } + man <- newManager defaultManagerSettings + let vcClientEnv = + mkVCClientEnv man $ + BaseUrl + { baseUrlScheme = Http, + baseUrlHost = "127.0.0.1", + baseUrlPort = 13077, + baseUrlPath = [] + } + putStrLn " Done." + + hspec $ spec vcClientEnv \ No newline at end of file From 927a46f9644e21695581b934c4073d03e2642293 Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Tue, 27 Jun 2023 04:49:13 +0000 Subject: [PATCH 7/9] Format --- inferno-vc/test/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inferno-vc/test/Spec.hs b/inferno-vc/test/Spec.hs index 8c4041e..074c9c4 100644 --- a/inferno-vc/test/Spec.hs +++ b/inferno-vc/test/Spec.hs @@ -222,4 +222,4 @@ main = } putStrLn " Done." - hspec $ spec vcClientEnv \ No newline at end of file + hspec $ spec vcClientEnv From dd1e66815d9b045bb460e9cd396e6b14f7551385 Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Tue, 27 Jun 2023 12:37:50 +0700 Subject: [PATCH 8/9] Disable `temporary` haddocks --- flake.nix | 2 ++ 1 file changed, 2 insertions(+) diff --git a/flake.nix b/flake.nix index 9120d3f..1be8ac1 100644 --- a/flake.nix +++ b/flake.nix @@ -144,6 +144,8 @@ packages = { # This takes forever to build ghc.components.library.doHaddock = false; + # Broken + temporary.components.library.doHaddock = false; }; packages.inferno-core = { enableLibraryProfiling = profiling; From c7213099bebcdad33b7d1977e97e935683d2501c Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Tue, 27 Jun 2023 06:03:08 +0000 Subject: [PATCH 9/9] Use temporary instead of ghc --- inferno-vc/inferno-vc.cabal | 2 +- inferno-vc/test/Spec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/inferno-vc/inferno-vc.cabal b/inferno-vc/inferno-vc.cabal index 4bc1d8e..0564ece 100644 --- a/inferno-vc/inferno-vc.cabal +++ b/inferno-vc/inferno-vc.cabal @@ -83,7 +83,6 @@ test-suite inferno-vc-tests build-depends: base >=4.7 && <5 , containers - , ghc , hspec , http-client , inferno-types @@ -92,6 +91,7 @@ test-suite inferno-vc-tests , servant-client , servant-server , servant-typed-error + , temporary , time default-language: Haskell2010 default-extensions: diff --git a/inferno-vc/test/Spec.hs b/inferno-vc/test/Spec.hs index 074c9c4..64c598c 100644 --- a/inferno-vc/test/Spec.hs +++ b/inferno-vc/test/Spec.hs @@ -11,7 +11,6 @@ import qualified Data.Set as Set import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Foreign.C (CTime (..)) -import GHC.Utils.TmpFs (withSystemTempDirectory) import Inferno.Types.Syntax (Expr (Lit), Lit (LDouble), TV (TV)) import Inferno.Types.Type (ImplType (ImplType), TCScheme (ForallTC), typeDouble) import Inferno.VersionControl.Client (ClientMWithVCStoreError, api, mkVCClientEnv) @@ -23,6 +22,7 @@ import Network.HTTP.Client (defaultManagerSettings, newManager) import Servant ((:<|>) (..)) import Servant.Client (BaseUrl (..), ClientEnv, Scheme (..), client) import Servant.Typed.Error (runTypedClientM, typedClient) +import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Test.QuickCheck (arbitrary, generate)