Reapply "[inferno-vc] Made fetchObjectClosureHashes return the root s…

…criptId and added logging to cached client and server (take 2)" (#140)

This reverts commit fcb00f4.

inferno-vc/CHANGELOG.md

@@ -1,6 +1,13 @@
 # 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.7.1
+version:             0.3.8.0
 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 as BL
+import qualified Data.ByteString.Lazy.Char8 as BL
 import Data.Either (partitionEithers)
 import Data.Generics.Product (HasType, getTyped)
 import Data.Generics.Sum (AsType (..))
@@ -36,6 +36,7 @@ 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
@@ -44,6 +45,7 @@ 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)
@@ -52,7 +54,8 @@ import System.FilePath.Posix ((</>))
 
 data VCCacheEnv = VCCacheEnv
   { cachePath :: FilePath,
-    cacheInFlight :: TVar (Set.Set VCObjectHash)
+    cacheInFlight :: TVar (Set.Set VCObjectHash),
+    tracer :: IOTracer VCCacheTrace
   }
   deriving (Generic)
 
@@ -77,11 +80,11 @@ data CachedVCClientError
   | LocalVCStoreError VCStoreError
   deriving (Show, Generic)
 
-initVCCachedClient :: FilePath -> IO VCCacheEnv
-initVCCachedClient cachePath = do
-  createDirectoryIfMissing True $ cachePath </> "deps"
+initVCCachedClient :: FilePath -> IOTracer VCCacheTrace -> IO VCCacheEnv
+initVCCachedClient cachePath tracer = do
+  createDirectoryIfMissing True $ cachePath </> "deps-v2"
   cacheInFlight <- newTVarIO mempty
-  pure VCCacheEnv {cachePath, cacheInFlight}
+  pure VCCacheEnv {cachePath, cacheInFlight, tracer}
 
 fetchVCObjectClosure ::
   ( MonadError err m,
@@ -103,27 +106,30 @@ fetchVCObjectClosure ::
   VCObjectHash ->
   m (Map.Map VCObjectHash (VCMeta a g VCObject))
 fetchVCObjectClosure fetchVCObjects remoteFetchVCObjectClosureHashes objHash = do
-  env@VCCacheEnv {cachePath} <- asks getTyped
+  env@VCCacheEnv {cachePath, tracer} <- asks getTyped
   deps <-
     withInFlight env [objHash] $
-      liftIO (doesFileExist $ cachePath </> "deps" </> show objHash) >>= \case
+      liftIO (doesFileExist $ cachePath </> "deps-v2" </> show objHash) >>= \case
         False -> do
+          traceWith tracer $ VCCacheDepsMiss objHash
           deps <- liftServantClient $ remoteFetchVCObjectClosureHashes objHash
-          liftIO
-            $ atomicWriteFile
-              (cachePath </> "deps" </> show objHash)
-            $ BL.concat [BL.fromStrict (vcObjectHashToByteString h) <> "\n" | h <- deps]
+          liftIO $
+            atomicWriteFile (cachePath </> "deps-v2" </> show objHash) $
+              BL.unlines $
+                map (BL.fromStrict . vcObjectHashToByteString) deps
           pure deps
-        True -> fetchVCObjectClosureHashes objHash
+        True -> do
+          traceWith tracer $ VCCacheDepsHit objHash
+          fetchVCObjectClosureHashes objHash
   withInFlight env deps $ do
     (nonLocalHashes, localHashes) <-
       partitionEithers
         <$> forM
-          (objHash : deps)
+          deps
           ( \depHash -> do
               liftIO (doesFileExist $ cachePath </> show depHash) >>= \case
-                True -> pure $ Right depHash
-                False -> pure $ Left depHash
+                True -> Right depHash <$ traceWith tracer (VCCacheHit depHash)
+                False -> Left depHash <$ traceWith tracer (VCCacheMiss depHash)
           )
     localObjs <-
       Map.fromList
@@ -149,7 +155,7 @@ fetchVCObjectClosureHashes ::
   m [VCObjectHash]
 fetchVCObjectClosureHashes h = do
   VCCacheEnv {cachePath} <- asks getTyped
-  let fp = cachePath </> "deps" </> show h
+  let fp = cachePath </> "deps-v2" </> show h
   readVCObjectHashTxt fp
 
 readVCObjectHashTxt ::
@@ -162,8 +168,11 @@ 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,
@@ -178,7 +187,8 @@ 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,9 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Inferno.VersionControl.Log where
+module Inferno.VersionControl.Log
+  ( VCServerTrace (..),
+    VCCacheTrace (..),
+    vcServerTraceToText,
+    vcCacheTraceToText,
+  )
+where
 
-import Data.Text (Text, pack)
+import Data.Text (Text, intercalate, pack)
 import Inferno.VersionControl.Operations.Error (VCStoreError, vcStoreErrorToString)
+import Inferno.VersionControl.Types (VCObjectHash)
 
 data VCServerTrace
   = ThrownVCStoreError VCStoreError
@@ -14,6 +21,8 @@ data VCServerTrace
   | ReadJSON FilePath
   | ReadTxt FilePath
   | DeleteFile FilePath
+  | VCFetchObjects [VCObjectHash]
+  | VCFetchObjectClosureHashes VCObjectHash
 
 vcServerTraceToText :: VCServerTrace -> Text
 vcServerTraceToText = \case
@@ -25,3 +34,18 @@ 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
-    readVCObjectHashTxt fp
+    (h :) <$> 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 (ThrownVCOtherError, ThrownVCStoreError), vcServerTraceToText)
+import Inferno.VersionControl.Log (VCServerTrace (..), vcServerTraceToText)
 import qualified Inferno.VersionControl.Operations as Ops
 import qualified Inferno.VersionControl.Operations.Error as Ops
 import Inferno.VersionControl.Server.Types (readServerConfig)
@@ -100,14 +100,21 @@ 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 =
+vcServer toHandler tracer =
   toHandler . fetchFunctionH
     :<|> toHandler . Ops.fetchFunctionsForGroups
     :<|> toHandler . Ops.fetchVCObject
     :<|> toHandler . Ops.fetchVCObjectHistory
-    :<|> toHandler . fetchVCObjects
-    :<|> toHandler . Ops.fetchVCObjectClosureHashes
+    :<|> ( \objs ->
+             traceWith tracer (VCFetchObjects objs)
+               >> toHandler (fetchVCObjects objs)
+         )
+    :<|> ( \obj ->
+             traceWith tracer (VCFetchObjectClosureHashes obj)
+               >> toHandler (Ops.fetchVCObjectClosureHashes obj)
+         )
     :<|> toHandler . pushFunctionH
     :<|> toHandler . Ops.deleteAutosavedVCObject
     :<|> toHandler . Ops.deleteVCObjects
@@ -187,7 +194,7 @@ runServerConfig middleware withEnv runOp serverConfig = do
           gzip def $
             middleware env $
               serve (Proxy :: Proxy (VersionControlAPI a g)) $
-                vcServer (liftIO . liftTypedError . flip runOp env)
+                vcServer (liftIO . liftTypedError . flip runOp env) serverTracer
 
 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 be empty as it has no dependencies:
+      -- The closure of h4 should only contain h4 as it has no dependencies:
       metas' <- runOperation vcClientEnv (fetchVCObjectClosureHashes h4)
-      metas' `shouldBe` []
+      metas' `shouldBe` [h4]
 
       -- After cloning h4 to h5, fetchFunctionsForGroups should return h4 and h5:
       o5 <- createObjForGroup g VCObjectPublic $ CloneOf h4