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; 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..0564ece 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 @@ -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 + , hspec + , http-client + , inferno-types + , inferno-vc + , QuickCheck + , servant-client + , servant-server + , servant-typed-error + , temporary + , 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/src/Inferno/VersionControl/Operations.hs b/inferno-vc/src/Inferno/VersionControl/Operations.hs index 65e46ee..7c9bf6b 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations.hs @@ -35,7 +35,6 @@ import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as BL 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 +339,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: newest to oldest + pure $ head_h : reverse preds + -- We recruse through history newest to oldest, and return the history in the same order: + 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 + 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 [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 [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 history >>= \res -> pure $ obj : res + _ -> getHistory history >>= \res -> pure $ obj : res + getHistory [] = pure [] + + 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 diff --git a/inferno-vc/test/Spec.hs b/inferno-vc/test/Spec.hs new file mode 100644 index 0000000..64c598c --- /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 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 System.IO.Temp (withSystemTempDirectory) +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