Revert "[inferno-vc] Made fetchObjectClosureHashes return the root scriptId and added logging to cached client and server (take 2)"

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
 

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

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
-  createDirectoryIfMissing True $ cachePath </> "deps-v2"
+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-v2" </> show objHash) >>= \case
+      liftIO (doesFileExist $ cachePath </> "deps" </> show objHash) >>= \case
         False -> do
-          traceWith tracer $ VCCacheDepsMiss objHash
           deps <- liftServantClient $ remoteFetchVCObjectClosureHashes objHash
-          liftIO $
-            atomicWriteFile (cachePath </> "deps-v2" </> 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
@@ -155,7 +149,7 @@ fetchVCObjectClosureHashes ::
   m [VCObjectHash]
 fetchVCObjectClosureHashes h = do
   VCCacheEnv {cachePath} <- asks getTyped
-  let fp = cachePath </> "deps-v2" </> show h
+  let fp = cachePath </> "deps" </> show h
   readVCObjectHashTxt fp
 
 readVCObjectHashTxt ::
@@ -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,

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)

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:

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

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