Concurrent tests for inferno-vc

.gitignore

@@ -24,3 +24,4 @@ cabal.project.local~
 result*
 .vscode/
 .venv/
+vc_store/

cabal.project

@@ -3,6 +3,7 @@ packages:
   ./inferno-types
   ./inferno-lsp
   ./inferno-vc
+  ../servant-conctest
 
 source-repository-package
     type: git
@@ -15,3 +16,9 @@ source-repository-package
     location: https://github.com/plow-technologies/hspec-golden-cereal.git
     tag: f9e3e485409c5a1de1de99a8ec0f35226c79da79
     --sha256: j+SZk5AZsNP674fb+1aiA7vrsk6Eq5BQM2losQSnaeE=
+
+-- source-repository-package
+--     type: git
+--     location: https://github.com/siddharth-krishna/servant-quickcheck.git
+--     tag: 8da2061928d194637c6c99486366bd2f9f2a16f0
+--     --sha256: PaaApUqHkBFVN7MWDm2oYBSBeRd/c6XmrF8Lat3Myks=

inferno-core/inferno-core.cabal

@@ -125,6 +125,57 @@ test-suite inferno-tests
     , RecordWildCards
   ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
 
+test-suite inferno-vc-tests
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test/VC
+  main-is:             Spec.hs
+  -- other-modules:
+  build-depends:
+      base >=4.7 && <5
+    , aeson
+    , async
+    -- , containers
+    , directory
+    -- , exceptions
+    , ghc
+    , hspec
+    -- , hspec-golden-aeson
+    -- , hspec-golden-cereal
+    , http-client
+    , http-types
+    , http-media
+    , inferno-core
+    , inferno-types
+    , inferno-vc
+    -- , megaparsec
+    , mtl
+    -- , prettyprinter
+    -- , pretty-simple
+    , plow-log
+    , QuickCheck
+    , quickcheck-instances
+    , servant
+    , servant-quickcheck
+    , servant-server
+    , string-conversions
+    -- , recursion-schemes
+    -- , text
+    , wai-logger
+    , warp
+  default-language:    Haskell2010
+  default-extensions:
+      DeriveDataTypeable
+    , DeriveFunctor
+    , DeriveGeneric
+    , FlexibleContexts
+    , FlexibleInstances
+    , LambdaCase
+    , OverloadedStrings
+    , TupleSections
+    , RecordWildCards
+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+  -- -threaded -fprof-auto "-with-rtsopts=-N -p"
+
 executable inferno
   main-is: Main.hs
   hs-source-dirs:

inferno-core/test/VC/Spec.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE DataKinds #-}
+
+module Main (main) where
+
+import qualified Data.Aeson as Aeson
+import Control.Exception (throw)
+import Control.Monad.Reader (runReaderT, when)
+import Data.Functor.Contravariant (contramap)
+import Inferno.Instances.Arbitrary ()
+import Inferno.VersionControl.Client (api)
+import Inferno.VersionControl.Log (vcServerTraceToString)
+import qualified Inferno.VersionControl.Operations as Ops
+import Inferno.VersionControl.Server (VersionControlAPI, vcServer)
+import Network.HTTP.Client (responseStatus, Response (..), httpLbs, Request, RequestBody (..), host, method, path, port, queryString, requestBody, requestHeaders, secure, defaultRequest)
+import Data.String.Conversions  (cs)
+import Network.HTTP.Types (status500)
+import Plow.Logging (IOTracer (..), simpleStdOutTracer)
+import Servant.Server (Server)
+import Servant.QuickCheck
+import Servant.QuickCheck.Internal.ErrorTypes (PredicateFailure (..))
+import Test.Hspec
+import Inferno.VersionControl.Operations.Error (VCStoreError(..))
+import GHC.Utils.TmpFs (withSystemTempDirectory)
+import System.Directory (removePathForcibly)
+import Test.QuickCheck (Result(..), quickCheckWithResult, Gen, Arbitrary (..), elements)
+import Control.Concurrent (newEmptyMVar, tryPutMVar, tryReadMVar)
+import Servant.QuickCheck.Internal.HasGenRequest (runGenRequest, HasGenRequest (..))
+import Test.QuickCheck.Monadic (monadicIO, forAllM, run, assert)
+import Servant.QuickCheck.Internal.Predicates (finishPredicates)
+import Servant.QuickCheck.Internal.QuickCheck (noCheckStatus, defManager)
+import Control.Concurrent.Async (concurrently)
+import Data.Proxy (Proxy (..))
+import Inferno.Types.Type (TCScheme)
+import Inferno.VersionControl.Types (VCObjectHash, Pinned, VCMeta)
+import Inferno.Types.Syntax (Expr)
+import Servant.API.ContentTypes (JSON (..), AllMimeRender (allMimeRender))
+import Network.HTTP.Media       (renderHeader)
+
+newtype VCApi = VCApi (VersionControlAPI Int Int)
+
+-- Test set: store successive versions of the same script, run fetchHistory for arbitrary versions
+-- Try to trigger CouldNotFindPath when fetchHistory reads wrong head
+instance HasGenRequest (VCApi) where
+  genRequest _ = (1, genStore)
+    where
+      genStore :: Gen (BaseUrl -> Request)
+      genStore = do
+        new' <- new
+        (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy '[JSON]) new'
+        return $ \burl -> defaultRequest
+          { host = cs $ baseUrlHost burl
+          , port = baseUrlPort burl
+          , secure = baseUrlScheme burl == Https
+          , method = "POST"
+          , path = "/push/function"
+          , requestBody = RequestBodyLBS bd
+          , requestHeaders = ("Content-Type", renderHeader ct) : []
+          }
+        where
+          -- TODO keep a list and point to correct pred
+          -- Do we need MTL for this? See GenT
+          -- TODO limit size of Expr
+          new = arbitrary :: Gen (VCMeta Int Int (Expr (Pinned VCObjectHash) (), TCScheme))
+      genFetchHist :: Gen (BaseUrl -> Request)
+      genFetchHist = return $ \burl -> defaultRequest
+        { host = cs $ baseUrlHost burl
+        , port = baseUrlPort burl
+        , secure = baseUrlScheme burl == Https
+        , method = "GET"
+        , path = "/fetch/X8-B10K4IF4blrwGl3oztxlw-0LAeiQvkx5bxvLrr4Y="
+        }
+
+noInternalError :: RequestPredicate
+noInternalError = RequestPredicate $ \req mgr -> do
+  resp <- httpLbs req mgr
+  putStrLn $ show req ++ show resp
+  when (responseStatus resp == status500) $ do
+    case ((Aeson.decode $ responseBody resp) :: Maybe VCStoreError) of
+      -- HACK: these are the non-errors, which should be 404s or other codes:
+      Just (CouldNotFindObject _) -> pure ()
+      Just (TryingToAppendToNonHead _) -> pure ()
+      Just (TryingToDeleteNonAutosave _) -> pure ()
+      _ -> do
+        putStrLn "BOO"
+        throw $ PredicateFailure "noInternalError" (Just req) resp
+  return [resp]
+
+spec :: Spec
+spec = describe "inferno-vc server" $ do
+  let maxTries = 20
+  let args = defaultArgs { maxSuccess = maxTries }
+  -- let args = defaultArgs
+
+  -- it "fixed store dir" $ do
+  --   let vcPath = "vc_store"
+  --   removePathForcibly vcPath
+  --   withServantServer testApi (pserver vcPath) $ \url ->
+  --     serverSatisfies testApi url args (noInternalError <%> mempty)
+
+  -- TODO switch to using temp dir
+  -- it "no internal errors" $ do
+  --   withSystemTempDirectory "vc_store_" $ \vcPath -> do
+  --     withServantServer testApi (pserver vcPath) $ \url ->
+  --       serverSatisfies testApi url args (noInternalError <%> mempty)
+  --       -- TODO this works. Is the problem our predicate?
+  --       -- serverSatisfies testApi url args (not500 <%> mempty)
+  --   putStrLn "Done"
+
+  it "concurrent test" $ do
+    let preds = noInternalError <%> mempty
+    let vcPath = "vc_store"
+    removePathForcibly vcPath
+    let proxyApi = Proxy :: Proxy VCApi
+
+    withServantServer testApi (pserver vcPath) $ \burl -> do
+      deetsMVar <- newEmptyMVar
+      let reqs = ($ burl) <$> runGenRequest proxyApi
+      let prop = monadicIO $ forAllM reqs $ \req -> do
+            v <- run $ finishPredicates preds (noCheckStatus req) defManager
+            _ <- run $ tryPutMVar deetsMVar v
+            case v of
+              Just _ -> assert False
+              _ -> return ()
+      -- TODO do both threads generate the exact same sequence of requests?
+      (res1, res2) <- concurrently
+        (quickCheckWithResult args {chatty = False} prop)
+        (quickCheckWithResult args {chatty = False} prop)
+      -- TODO need a way to kill other threads when property violated in one thread
+      case (res1, res2) of
+        (Success {}, Success {}) -> return ()
+        _ -> do
+          mx <- tryReadMVar deetsMVar
+          case mx of
+            Just x ->
+              expectationFailure $ "Failed:\n" ++ show x
+            Nothing ->
+              expectationFailure $ "We failed to record a reason for failure: " <> show (res1, res2)
+
+  where
+    tracer = contramap vcServerTraceToString $ IOTracer $ simpleStdOutTracer
+
+    testApi :: Proxy (VersionControlAPI Int Int)
+    testApi = api
+
+    pserver :: FilePath -> IO (Server (VersionControlAPI Int Int))
+    pserver vcPath = do
+      putStrLn $ "Store is at: " ++ (show vcPath)
+      runReaderT Ops.initVCStore $ Ops.VCStorePath vcPath
+      print ("running..." :: String)
+      return $ vcServer vcPath tracer
+
+main :: IO ()
+main =
+  hspec spec

inferno-vc/inferno-vc.cabal

@@ -43,7 +43,9 @@ library
     , directory                          >= 1.3.6 && < 1.4
     , filepath                           >= 1.4.2 && < 1.5
     , generic-lens                       >= 2.2.1 && < 2.3
-    , http-client                        >= 0.7.13 && < 0.8
+    -- TODO version bounds
+    , ghc
+    , http-client                        >= 0.6.4 && < 0.7
     , http-types                         >= 0.12.3 && < 0.13
     , inferno-types                      >= 0.1.0 && < 0.2
     , lens                               >= 5.2 && < 5.3
@@ -74,6 +76,27 @@ 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-conctest
+    , servant-server
+    , servant-typed-error
+    , temporary
+    , time
+  default-language:    Haskell2010
+  ghc-options: -Wall -Wunused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -with-rtsopts=-N
+
 -- An example executable definition, needs instantation of author/group types:
 -- executable inferno-vc-server
 --   main-is: Main.hs

inferno-vc/src/Inferno/VersionControl/Operations.hs

@@ -38,6 +38,7 @@ import Data.Text (pack)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Foreign.C.Types (CTime (..))
 import GHC.Generics (Generic)
+import GHC.Utils.Monad (unlessM)
 import Inferno.Types.Syntax (Dependencies (..))
 import Inferno.VersionControl.Log (VCServerTrace (..))
 import Inferno.VersionControl.Operations.Error (VCStoreError (..))
@@ -52,7 +53,7 @@ import Inferno.VersionControl.Types
     vcObjectHashToByteString,
   )
 import Plow.Logging (IOTracer, traceWith)
-import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeFile, renameFile)
+import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeFile, renameFile, removePathForcibly)
 import System.FilePath.Posix (takeFileName, (</>))
 
 newtype VCStorePath = VCStorePath FilePath deriving (Generic)
@@ -85,16 +86,16 @@ initVCCachedClient =
   (getTyped <$> ask) >>= \(VCStorePath storePath) -> liftIO $ do
     createDirectoryIfMissing True $ storePath </> "deps"
 
-checkPathExists :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m ()
-checkPathExists fp =
+assertPathExists :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m ()
+assertPathExists fp =
   liftIO (doesFileExist fp) >>= \case
     False -> throwError $ CouldNotFindPath fp
     True -> pure ()
 
 getDepsFromStore :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> VCObjectHash -> m BL.ByteString
 getDepsFromStore path h = do
   let fp = path </> show h
-  checkPathExists fp
+  unlessM (liftIO $ doesFileExist fp) $ throwError $ CouldNotFindObject h
   liftIO $ BL.readFile $ path </> show h
 
 appendBS :: (VCStoreLogM env m) => FilePath -> BL.ByteString -> m ()
@@ -120,13 +121,21 @@ writeHashedJSON path o = do
 
 readVCObjectHashTxt :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m [VCObjectHash]
 readVCObjectHashTxt fp = do
-  checkPathExists fp
+  assertPathExists fp
   trace $ ReadTxt fp
   deps <- filter (not . B.null) . Char8.lines <$> (liftIO $ B.readFile fp)
   forM deps $ \dep -> do
     decoded <- either (const $ throwError $ InvalidHash $ Char8.unpack dep) pure $ Base64.decode dep
     maybe (throwError $ InvalidHash $ Char8.unpack dep) (pure . VCObjectHash) $ digestFromByteString decoded
 
+-- | RESET the VC store: deletes all objects permanently and resets to initial state.
+-- Intended to be used for testing only.
+resetVC :: VCStoreEnvM env m => m ()
+resetVC = do
+  VCStorePath storePath <- getTyped <$> ask
+  liftIO $ removePathForcibly storePath
+  initVCStore
+
 storeVCObject :: forall env err m a g. (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, VCHashUpdate a, VCHashUpdate g, ToJSON a, ToJSON g, FromJSON a, FromJSON g) => VCMeta a g VCObject -> m VCObjectHash
 storeVCObject obj@VCMeta {obj = ast, pred = p} = do
   VCStorePath storePath <- getTyped <$> ask
@@ -262,7 +271,7 @@ fetchVCObject' mprefix h = do
   let fp = case mprefix of
         Nothing -> storePath </> show h
         Just prefix -> storePath </> prefix </> show h
-  checkPathExists fp
+  unlessM (liftIO $ doesFileExist fp) $ throwError $ CouldNotFindObject h
   trace $ ReadJSON fp
   either (throwError . CouldNotDecodeObject h) pure =<< (liftIO $ eitherDecode <$> BL.readFile fp)
 
@@ -274,6 +283,7 @@ fetchVCObjectClosureHashes :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM
 fetchVCObjectClosureHashes h = do
   VCStorePath storePath <- getTyped <$> ask
   let fp = storePath </> "deps" </> show h
+  unlessM (liftIO $ doesFileExist fp) $ throwError $ CouldNotFindObject h
   readVCObjectHashTxt fp
 
 fetchVCObjectWithClosure :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m (Map.Map VCObjectHash (VCMeta a g VCObject))
@@ -296,7 +306,7 @@ fetchCurrentHead h = do
       readVCObjectHashTxt fp >>= \case
         [h'] -> pure h'
         _ -> throwError $ CouldNotFindHead h
-    else throwError $ CouldNotFindHead h
+    else throwError $ CouldNotFindObject h
 
 fetchVCObjectHistory :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m [VCMeta a g VCObjectHash]
 fetchVCObjectHistory h = do