From dd44b59884cb3259d71b96ea996733eb5aaf6cc4 Mon Sep 17 00:00:00 2001 From: Brent Date: Fri, 11 Oct 2024 16:54:00 -0500 Subject: [PATCH] =?UTF-8?q?Revert=20"[inferno-vc]=20Made=20fetchObjectClos?= =?UTF-8?q?ureHashes=20return=20the=20root=20scriptId=20a=E2=80=A6"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This reverts commit 8cc5e91ba14edd60789169488a63926251c17d2b. --- inferno-vc/CHANGELOG.md | 7 --- inferno-vc/inferno-vc.cabal | 2 +- .../Inferno/VersionControl/Client/Cached.hs | 44 +++++++------------ inferno-vc/src/Inferno/VersionControl/Log.hs | 28 +----------- .../VersionControl/Operations/Filesystem.hs | 2 +- .../src/Inferno/VersionControl/Server.hs | 17 +++---- .../src/Inferno/VersionControl/Testing.hs | 4 +- 7 files changed, 28 insertions(+), 76 deletions(-) diff --git a/inferno-vc/CHANGELOG.md b/inferno-vc/CHANGELOG.md index aba8f8d9..f572decc 100644 --- a/inferno-vc/CHANGELOG.md +++ b/inferno-vc/CHANGELOG.md @@ -1,13 +1,6 @@ # Revision History for inferno-vc *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) -## 0.3.8.0 -- 2024-10-11 -* Made fetchObjectClosureHashes return the scriptId used to call it since it - also belongs in the closure. -* Added logging to cached client to see hits and misses -* Added logging to server to see what scriptIds are being used to request - fetchObjects and fetchObjectClosureHashes - ## 0.3.7.1 -- 2024-09-23 * Fix overflowing threadDelay on armv7l diff --git a/inferno-vc/inferno-vc.cabal b/inferno-vc/inferno-vc.cabal index 8da3e675..38f8ac4a 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.3.8.0 +version: 0.3.7.1 synopsis: Version control server for Inferno description: A version control server for Inferno scripts category: DSL,Scripting diff --git a/inferno-vc/src/Inferno/VersionControl/Client/Cached.hs b/inferno-vc/src/Inferno/VersionControl/Client/Cached.hs index 9418e338..7f049a8c 100644 --- a/inferno-vc/src/Inferno/VersionControl/Client/Cached.hs +++ b/inferno-vc/src/Inferno/VersionControl/Client/Cached.hs @@ -27,7 +27,7 @@ import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode) 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.Char8 as BL +import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers) import Data.Generics.Product (HasType, getTyped) import Data.Generics.Sum (AsType (..)) @@ -36,7 +36,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import GHC.Generics (Generic) import qualified Inferno.VersionControl.Client as VCClient -import Inferno.VersionControl.Log (VCCacheTrace (..)) import Inferno.VersionControl.Operations.Error (VCStoreError (..)) import Inferno.VersionControl.Server (VCServerError) import Inferno.VersionControl.Types @@ -45,7 +44,6 @@ import Inferno.VersionControl.Types VCObjectHash (..), vcObjectHashToByteString, ) -import Plow.Logging (IOTracer (..), traceWith) import Servant.Client (ClientEnv, ClientError) import Servant.Typed.Error (TypedClientM, runTypedClientM) import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile) @@ -54,8 +52,7 @@ import System.FilePath.Posix (()) data VCCacheEnv = VCCacheEnv { cachePath :: FilePath, - cacheInFlight :: TVar (Set.Set VCObjectHash), - tracer :: IOTracer VCCacheTrace + cacheInFlight :: TVar (Set.Set VCObjectHash) } deriving (Generic) @@ -80,11 +77,11 @@ data CachedVCClientError | LocalVCStoreError VCStoreError deriving (Show, Generic) -initVCCachedClient :: FilePath -> IOTracer VCCacheTrace -> IO VCCacheEnv -initVCCachedClient cachePath tracer = do +initVCCachedClient :: FilePath -> IO VCCacheEnv +initVCCachedClient cachePath = do createDirectoryIfMissing True $ cachePath "deps" cacheInFlight <- newTVarIO mempty - pure VCCacheEnv {cachePath, cacheInFlight, tracer} + pure VCCacheEnv {cachePath, cacheInFlight} fetchVCObjectClosure :: ( MonadError err m, @@ -106,30 +103,27 @@ fetchVCObjectClosure :: VCObjectHash -> m (Map.Map VCObjectHash (VCMeta a g VCObject)) fetchVCObjectClosure fetchVCObjects remoteFetchVCObjectClosureHashes objHash = do - env@VCCacheEnv {cachePath, tracer} <- asks getTyped + env@VCCacheEnv {cachePath} <- asks getTyped deps <- withInFlight env [objHash] $ liftIO (doesFileExist $ cachePath "deps" show objHash) >>= \case False -> do - traceWith tracer $ VCCacheDepsMiss objHash deps <- liftServantClient $ remoteFetchVCObjectClosureHashes objHash - liftIO $ - atomicWriteFile (cachePath "deps" show objHash) $ - BL.unlines $ - map (BL.fromStrict . vcObjectHashToByteString) deps + liftIO + $ atomicWriteFile + (cachePath "deps" show objHash) + $ BL.concat [BL.fromStrict (vcObjectHashToByteString h) <> "\n" | h <- deps] pure deps - True -> do - traceWith tracer $ VCCacheDepsHit objHash - fetchVCObjectClosureHashes objHash + True -> fetchVCObjectClosureHashes objHash withInFlight env deps $ do (nonLocalHashes, localHashes) <- partitionEithers <$> forM - deps + (objHash : deps) ( \depHash -> do liftIO (doesFileExist $ cachePath show depHash) >>= \case - True -> Right depHash <$ traceWith tracer (VCCacheHit depHash) - False -> Left depHash <$ traceWith tracer (VCCacheMiss depHash) + True -> pure $ Right depHash + False -> pure $ Left depHash ) localObjs <- Map.fromList @@ -168,11 +162,8 @@ readVCObjectHashTxt :: readVCObjectHashTxt fp = do deps <- filter (not . B.null) . Char8.lines <$> liftIO (B.readFile fp) forM deps $ \dep -> do - decoded <- - either (const $ throwing _Typed $ InvalidHash $ Char8.unpack dep) pure $ - Base64.decode dep - maybe (throwing _Typed $ InvalidHash $ Char8.unpack dep) (pure . VCObjectHash) $ - digestFromByteString decoded + decoded <- either (const $ throwing _Typed $ InvalidHash $ Char8.unpack dep) pure $ Base64.decode dep + maybe (throwing _Typed $ InvalidHash $ Char8.unpack dep) (pure . VCObjectHash) $ digestFromByteString decoded fetchVCObjectUnsafe :: ( MonadReader r m, @@ -187,8 +178,7 @@ fetchVCObjectUnsafe :: fetchVCObjectUnsafe h = do VCCacheEnv {cachePath} <- asks getTyped let fp = cachePath show h - either (throwing _Typed . CouldNotDecodeObject h) pure - =<< liftIO (eitherDecodeStrict <$> Char8.readFile fp) + either (throwing _Typed . CouldNotDecodeObject h) pure =<< liftIO (eitherDecodeStrict <$> Char8.readFile fp) liftServantClient :: ( MonadError e m, diff --git a/inferno-vc/src/Inferno/VersionControl/Log.hs b/inferno-vc/src/Inferno/VersionControl/Log.hs index 9f1cc73f..5f76a878 100644 --- a/inferno-vc/src/Inferno/VersionControl/Log.hs +++ b/inferno-vc/src/Inferno/VersionControl/Log.hs @@ -1,16 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Inferno.VersionControl.Log - ( VCServerTrace (..), - VCCacheTrace (..), - vcServerTraceToText, - vcCacheTraceToText, - ) -where +module Inferno.VersionControl.Log where -import Data.Text (Text, intercalate, pack) +import Data.Text (Text, pack) import Inferno.VersionControl.Operations.Error (VCStoreError, vcStoreErrorToString) -import Inferno.VersionControl.Types (VCObjectHash) data VCServerTrace = ThrownVCStoreError VCStoreError @@ -21,8 +14,6 @@ data VCServerTrace | ReadJSON FilePath | ReadTxt FilePath | DeleteFile FilePath - | VCFetchObjects [VCObjectHash] - | VCFetchObjectClosureHashes VCObjectHash vcServerTraceToText :: VCServerTrace -> Text vcServerTraceToText = \case @@ -34,18 +25,3 @@ vcServerTraceToText = \case ThrownVCStoreError e -> pack (vcStoreErrorToString e) ThrownVCOtherError e -> "Other server error: " <> e DeleteFile fp -> "Deleting file: " <> pack fp - VCFetchObjects objs -> "FetchObjects " <> intercalate ", " (map (pack . show) objs) - VCFetchObjectClosureHashes obj -> "FetchObjectClosureHashes " <> pack (show obj) - -data VCCacheTrace - = VCCacheHit VCObjectHash - | VCCacheMiss VCObjectHash - | VCCacheDepsHit VCObjectHash - | VCCacheDepsMiss VCObjectHash - -vcCacheTraceToText :: VCCacheTrace -> Text -vcCacheTraceToText = \case - VCCacheHit h -> "✅ VC Cache hit " <> pack (show h) - VCCacheMiss h -> "❌ VC Cache miss " <> pack (show h) - VCCacheDepsHit h -> "✅ VC Cache deps hit " <> pack (show h) - VCCacheDepsMiss h -> "❌ VC Cache deps miss " <> pack (show h) diff --git a/inferno-vc/src/Inferno/VersionControl/Operations/Filesystem.hs b/inferno-vc/src/Inferno/VersionControl/Operations/Filesystem.hs index 3968b0d5..ff60a353 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations/Filesystem.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations/Filesystem.hs @@ -341,7 +341,7 @@ instance fetchVCObjectClosureHashes h = do VCStorePath storePath <- asks getTyped let fp = storePath "deps" show h - (h :) <$> readVCObjectHashTxt fp + readVCObjectHashTxt fp deleteAutosavedVCObjectsOlderThan t = do -- We know that all autosaves must be heads: diff --git a/inferno-vc/src/Inferno/VersionControl/Server.hs b/inferno-vc/src/Inferno/VersionControl/Server.hs index fa0abbd4..e8414ed8 100644 --- a/inferno-vc/src/Inferno/VersionControl/Server.hs +++ b/inferno-vc/src/Inferno/VersionControl/Server.hs @@ -37,7 +37,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import GHC.Generics (Generic) import Inferno.Types.Syntax (Expr) import Inferno.Types.Type (TCScheme) -import Inferno.VersionControl.Log (VCServerTrace (..), vcServerTraceToText) +import Inferno.VersionControl.Log (VCServerTrace (ThrownVCOtherError, ThrownVCStoreError), vcServerTraceToText) import qualified Inferno.VersionControl.Operations as Ops import qualified Inferno.VersionControl.Operations.Error as Ops import Inferno.VersionControl.Server.Types (readServerConfig) @@ -100,21 +100,14 @@ vcServer :: Ord (Ops.Group m) ) => (forall x. m x -> Handler (Union (WithError VCServerError x))) -> - IOTracer VCServerTrace -> Server (VersionControlAPI (Ops.Author m) (Ops.Group m)) -vcServer toHandler tracer = +vcServer toHandler = toHandler . fetchFunctionH :<|> toHandler . Ops.fetchFunctionsForGroups :<|> toHandler . Ops.fetchVCObject :<|> toHandler . Ops.fetchVCObjectHistory - :<|> ( \objs -> - traceWith tracer (VCFetchObjects objs) - >> toHandler (fetchVCObjects objs) - ) - :<|> ( \obj -> - traceWith tracer (VCFetchObjectClosureHashes obj) - >> toHandler (Ops.fetchVCObjectClosureHashes obj) - ) + :<|> toHandler . fetchVCObjects + :<|> toHandler . Ops.fetchVCObjectClosureHashes :<|> toHandler . pushFunctionH :<|> toHandler . Ops.deleteAutosavedVCObject :<|> toHandler . Ops.deleteVCObjects @@ -194,7 +187,7 @@ runServerConfig middleware withEnv runOp serverConfig = do gzip def $ middleware env $ serve (Proxy :: Proxy (VersionControlAPI a g)) $ - vcServer (liftIO . liftTypedError . flip runOp env) serverTracer + vcServer (liftIO . liftTypedError . flip runOp env) withLinkedAsync_ :: IO a -> IO b -> IO b withLinkedAsync_ f g = withAsync f $ \h -> link h >> g diff --git a/inferno-vc/src/Inferno/VersionControl/Testing.hs b/inferno-vc/src/Inferno/VersionControl/Testing.hs index 18edc990..eb018e13 100644 --- a/inferno-vc/src/Inferno/VersionControl/Testing.hs +++ b/inferno-vc/src/Inferno/VersionControl/Testing.hs @@ -143,9 +143,9 @@ vcServerSpec url = do metas <- runOperation vcClientEnv (fetchFunctionsForGroups (Set.singleton g)) map obj metas `shouldBe` [h4] - -- The closure of h4 should only contain h4 as it has no dependencies: + -- The closure of h4 should be empty as it has no dependencies: metas' <- runOperation vcClientEnv (fetchVCObjectClosureHashes h4) - metas' `shouldBe` [h4] + metas' `shouldBe` [] -- After cloning h4 to h5, fetchFunctionsForGroups should return h4 and h5: o5 <- createObjForGroup g VCObjectPublic $ CloneOf h4