packages feed

inferno-vc (empty) → 0.1.0

raw patch · 12 files changed

+1053/−0 lines, 12 filesdep +QuickCheckdep +aesondep +async

Dependencies added: QuickCheck, aeson, async, base, base64-bytestring, bytestring, containers, cryptonite, directory, filepath, generic-lens, http-client, http-types, inferno-types, lens, mtl, plow-log, quickcheck-arbitrary-adt, quickcheck-instances, servant, servant-client, servant-server, servant-typed-error, text, time, wai, wai-extra, warp, yaml, zlib

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Revision History for inferno-vc++## 0.1.0.0 -- 2022-11-28+* Prepare for OSS release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Plow Technologies++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ inferno-vc.cabal view
@@ -0,0 +1,89 @@+cabal-version:       >=1.10+name:                inferno-vc+version:             0.1.0+synopsis:            Version control server for Inferno+description:         A version control server for Inferno scripts+category:            DSL,Scripting+homepage:            https://github.com/plow-technologies/inferno.git#readme+bug-reports:         https://github.com/plow-technologies/inferno.git/issues+copyright:           Plow-Technologies LLC+license:             MIT+license-file:        LICENSE+author:              Sam Balco+maintainer:          info@plowtech.net+build-type:          Simple+extra-source-files:  CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/plow-technologies/inferno.git++library+  exposed-modules:+      Inferno.VersionControl.Client+    , Inferno.VersionControl.Client.Cached+    , Inferno.VersionControl.Operations+    , Inferno.VersionControl.Operations.Error+    , Inferno.VersionControl.Log+    , Inferno.VersionControl.Server+    , Inferno.VersionControl.Server.Types+    , Inferno.VersionControl.Server.UnzipRequest+    , Inferno.VersionControl.Types+  hs-source-dirs:+      src+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+  build-depends:+      aeson                              >= 2.1.1 && < 2.2+    , async                              >= 2.2.4 && < 2.3+    , base                               >= 4.13 && < 4.17+    , base64-bytestring                  >= 1.2.1 && < 1.3+    , bytestring                         >= 0.10.10 && < 0.12+    , containers                         >= 0.6.2 && < 0.7+    , cryptonite                         >= 0.30 && < 0.31+    , 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+    , http-types                         >= 0.12.3 && < 0.13+    , inferno-types                      >= 0.1.0 && < 0.2+    , lens                               >= 5.2 && < 5.3+    , mtl                                >= 2.2.2 && < 2.3+    , plow-log                           >= 0.1.6 && < 0.2+    , QuickCheck                         >= 2.14.2 && < 2.15+    , quickcheck-arbitrary-adt           >= 0.3.1 && < 0.4+    , quickcheck-instances               >= 0.3.28 && < 0.4+    , servant                            >= 0.19 && < 0.20+    , servant-client                     >= 0.19 && < 0.20+    , servant-server                     >= 0.19.1 && < 0.20+    , servant-typed-error                >= 0.1.2 && < 0.2+    , text                               >= 2.0.1 && < 2.1+    , time                               >= 1.9.3 && < 1.12+    , wai                                >= 3.2.3 && < 3.3+    , wai-extra                          >= 3.1.12 && < 3.2+    , warp                               >= 3.3.23 && < 3.4+    , yaml                               >= 0.11.8 && < 0.12+    , zlib                               >= 0.6.3 && < 0.7++  default-language: Haskell2010+  default-extensions:+      DeriveDataTypeable+    , DeriveFunctor+    , DeriveGeneric+    , FlexibleContexts+    , FlexibleInstances+    , LambdaCase+    , MultiParamTypeClasses+    , OverloadedStrings+    , TupleSections+    , RecordWildCards++-- An example executable definition, needs instantation of author/group types:+-- executable inferno-vc-server+--   main-is: Main.hs+--   hs-source-dirs:+--       app+--   ghc-options: -Wall -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-T+--   build-depends:+--       base >=4.7 && <5+--     , inferno-vc+--   default-language: Haskell2010
+ src/Inferno/VersionControl/Client.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Inferno.VersionControl.Client where++import Codec.Compression.GZip (compress)+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString.Lazy as BSL+import Data.Proxy (Proxy (..))+import Inferno.VersionControl.Server (VCServerError, VersionControlAPI)+import Network.HTTP.Client (Request (..), RequestBody (..))+import Network.HTTP.Client.Internal (Manager (..))+import Network.HTTP.Types.Header (hContentEncoding)+import Servant.Client (BaseUrl, Client, ClientEnv, ClientM, client, mkClientEnv)+import Servant.Typed.Error (TypedClientM)++mkVCClientEnv :: Manager -> BaseUrl -> ClientEnv+mkVCClientEnv man@Manager {mModifyRequest = modReq} baseUrl =+  mkClientEnv man {mModifyRequest = modReq'} baseUrl+  where+    modReq' :: Request -> IO Request+    modReq' r = do+      x <- modReq r+      pure $+        if ((hContentEncoding, "gzip") `elem` requestHeaders x)+          then x+          else+            let new_hdrs = (hContentEncoding, "gzip") : requestHeaders x+                (hrds, body) = case requestBody x of+                  RequestBodyBuilder _ _ -> (requestHeaders x, requestBody x)+                  RequestBodyStream _ _ -> (requestHeaders x, requestBody x)+                  RequestBodyStreamChunked _ -> (requestHeaders x, requestBody x)+                  b -> (new_hdrs, compressBody b)+             in x {requestHeaders = hrds, requestBody = body}++    compressBody :: RequestBody -> RequestBody+    compressBody = \case+      RequestBodyLBS bsl -> RequestBodyLBS $ compress bsl+      RequestBodyBS bs -> RequestBodyLBS $ compress $ BSL.fromStrict bs+      RequestBodyIO iob -> RequestBodyIO $ compressBody <$> iob+      b -> b++api :: Proxy (VersionControlAPI a g)+api = Proxy++infernoVcClient :: (FromJSON a, FromJSON g, ToJSON a, ToJSON g) => Client ClientM (VersionControlAPI a g)+infernoVcClient = client api++-- TODO Generate this block below using TH given a and g:++type ClientMWithVCStoreError a = TypedClientM VCServerError a++-- fetchFunction :: forall a g. VCObjectHash -> ClientMWithVCStoreError (VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme))+-- fetchFunctionsForGroups :: forall a g. Set g -> ClientMWithVCStoreError [VCMeta a g VCObjectHash]+-- fetchVCObject :: forall a g. VCObjectHash -> ClientMWithVCStoreError (VCMeta a g VCObject)+-- fetchVCObjectHistory :: forall a g. VCObjectHash -> ClientMWithVCStoreError [VCMeta a g VCObjectHash]+-- fetchVCObjects :: forall a g. [VCObjectHash] -> ClientMWithVCStoreError (Map.Map VCObjectHash (VCMeta a g VCObject))+-- fetchVCObjectClosureHashes :: VCObjectHash -> ClientMWithVCStoreError [VCObjectHash]+-- pushFunction :: forall a g. VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme) -> ClientMWithVCStoreError VCObjectHash+-- deleteAutosavedFunction :: VCObjectHash -> ClientMWithVCStoreError ()+-- deleteVCObjects :: VCObjectHash -> ClientMWithVCStoreError ()+-- fetchFunction+--   :<|> fetchFunctionsForGroups+--   :<|> fetchVCObject+--   :<|> fetchVCObjectHistory+--   :<|> fetchVCObjects+--   :<|> fetchVCObjectClosureHashes+--   :<|> pushFunction+--   :<|> deleteAutosavedFunction+--   :<|> deleteVCObjects = typedClient $ client api
+ src/Inferno/VersionControl/Client/Cached.hs view
@@ -0,0 +1,101 @@+module Inferno.VersionControl.Client.Cached where++import Control.Monad (forM, forM_)+import Control.Monad.Error.Lens (throwing)+import Control.Monad.Except (MonadError (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader (..))+import Data.Aeson (FromJSON, ToJSON, encode)+import qualified Data.ByteString.Lazy as BL+import Data.Either (partitionEithers)+import Data.Generics.Product (HasType, getTyped)+import Data.Generics.Sum (AsType (..))+import qualified Data.Map as Map+import GHC.Generics (Generic)+import qualified Inferno.VersionControl.Client as VCClient+import Inferno.VersionControl.Log (VCServerTrace)+import qualified Inferno.VersionControl.Operations as Ops+import qualified Inferno.VersionControl.Operations.Error as Ops+import Inferno.VersionControl.Server (VCServerError)+import Inferno.VersionControl.Types+  ( VCMeta,+    VCObject,+    VCObjectHash,+    vcObjectHashToByteString,+  )+import Plow.Logging (IOTracer)+import Servant.Client (ClientEnv, ClientError)+import Servant.Typed.Error (TypedClientM, runTypedClientM)+import System.Directory (doesFileExist)+import System.FilePath.Posix ((</>))++data CachedVCClientError+  = ClientVCStoreError VCServerError+  | ClientServantError ClientError+  | LocalVCStoreError Ops.VCStoreError+  deriving (Show, Generic)++liftServantClient ::+  ( MonadError e m,+    MonadIO m,+    MonadReader s m,+    HasType ClientEnv s,+    AsType a e,+    AsType ClientError e+  ) =>+  TypedClientM a b ->+  m b+liftServantClient m = do+  client <- getTyped <$> ask+  (liftIO $ runTypedClientM m client) >>= \case+    Left (Left clientErr) -> throwing _Typed $ clientErr+    Left (Right serverErr) -> throwing _Typed $ serverErr+    Right res -> pure res++fetchVCObjectClosure ::+  ( AsType VCServerError err,+    AsType ClientError err,+    AsType Ops.VCStoreError err,+    MonadError err m,+    HasType (IOTracer VCServerTrace) env,+    HasType Ops.VCStorePath env,+    HasType ClientEnv env,+    MonadReader env m,+    MonadIO m,+    FromJSON a,+    FromJSON g,+    ToJSON a,+    ToJSON g+  ) =>+  ([VCObjectHash] -> VCClient.ClientMWithVCStoreError (Map.Map VCObjectHash (VCMeta a g VCObject))) ->+  (VCObjectHash -> VCClient.ClientMWithVCStoreError [VCObjectHash]) ->+  VCObjectHash ->+  m (Map.Map VCObjectHash (VCMeta a g VCObject))+fetchVCObjectClosure fetchVCObjects fetchVCObjectClosureHashes objHash = do+  Ops.VCStorePath storePath <- getTyped <$> ask+  deps <-+    (liftIO $ doesFileExist $ storePath </> "deps" </> show objHash) >>= \case+      False -> do+        deps <- liftServantClient $ fetchVCObjectClosureHashes objHash+        Ops.writeBS+          (storePath </> "deps" </> show objHash)+          $ BL.concat [BL.fromStrict (vcObjectHashToByteString h) <> "\n" | h <- deps]+        pure deps+      True -> Ops.fetchVCObjectClosureHashes objHash+  (nonLocalHashes, localHashes) <-+    partitionEithers+      <$> ( forM (objHash : deps) $ \depHash -> do+              (liftIO $ doesFileExist $ storePath </> show depHash) >>= \case+                True -> pure $ Right depHash+                False -> pure $ Left depHash+          )+  localObjs <-+    Map.fromList+      <$> ( forM localHashes $ \h ->+              (h,) <$> Ops.fetchVCObject h+          )++  nonLocalObjs <- liftServantClient $ fetchVCObjects nonLocalHashes+  forM_ (Map.toList nonLocalObjs) $ \(h, o) ->+    liftIO $ BL.writeFile (storePath </> show h) $ encode o+  pure $ localObjs `Map.union` nonLocalObjs
+ src/Inferno/VersionControl/Log.hs view
@@ -0,0 +1,22 @@+module Inferno.VersionControl.Log where++import Inferno.VersionControl.Operations.Error (VCStoreError, vcStoreErrorToString)++data VCServerTrace+  = ThrownVCStoreError VCStoreError+  | WriteJSON FilePath+  | WriteTxt FilePath+  | AlreadyExistsJSON FilePath+  | ReadJSON FilePath+  | ReadTxt FilePath+  | DeleteFile FilePath++vcServerTraceToString :: VCServerTrace -> String+vcServerTraceToString = \case+  WriteJSON fp -> "Writing JSON at: " <> fp+  WriteTxt fp -> "Writing TXT at: " <> fp+  AlreadyExistsJSON fp -> "JSON already exists at: " <> fp+  ReadJSON fp -> "Reading JSON at: " <> fp+  ReadTxt fp -> "Reading TXT at: " <> fp+  ThrownVCStoreError e -> vcStoreErrorToString e+  DeleteFile fp -> "Deleting file: " <> fp
+ src/Inferno/VersionControl/Operations.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Inferno.VersionControl.Operations+-- Description : Operations on the Inferno version control store+--+-- This module defines operations on the Inferno VC store. The store structure is as follows:+--+-- * `<storePath>` stores the JSON serialised `VCMeta VCObject`s, where the filename is the cryptographic hash (`VCOBjectHash`) of the object's contents+-- * `<storePath>/heads` is a set of current HEAD objects of the store, which can be seen as the roots of the VC tree+-- * `<storePath>/to_head` is a map from every `VCOBjectHash` to its current HEAD, where the file name is the source hash and the contents of the file are the HEAD hash+-- * `<storePath>/deps` is a map from every `VCOBjectHash` to its (transitive) dependencies, i.e. the file `<storePath>/deps/<hash>` describes the closure of `<hash>`+module Inferno.VersionControl.Operations where++import Control.Monad (filterM, foldM, forM, forM_)+import Control.Monad.Error.Lens (throwing)+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader (..))+import Crypto.Hash (digestFromByteString)+import Data.Aeson (FromJSON, ToJSON, Value, eitherDecode, 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 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)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Foreign.C.Types (CTime (..))+import GHC.Generics (Generic)+import Inferno.Types.Syntax (Dependencies (..))+import Inferno.VersionControl.Log (VCServerTrace (..))+import Inferno.VersionControl.Operations.Error (VCStoreError (..))+import Inferno.VersionControl.Types+  ( VCHashUpdate,+    VCMeta (..),+    VCObject (..),+    VCObjectHash (..),+    VCObjectPred (..),+    VCObjectVisibility (..),+    vcHash,+    vcObjectHashToByteString,+  )+import Plow.Logging (IOTracer, traceWith)+import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeFile, renameFile)+import System.FilePath.Posix (takeFileName, (</>))++newtype VCStorePath = VCStorePath FilePath deriving (Generic)++type VCStoreErrM err m = (AsType VCStoreError err, MonadError err m, MonadIO m)++type VCStoreLogM env m = (HasType (IOTracer VCServerTrace) env, MonadReader env m, MonadIO m)++type VCStoreEnvM env m = (HasType VCStorePath env, MonadReader env m, MonadIO m)++trace :: VCStoreLogM env m => VCServerTrace -> m ()+trace t = do+  tracer <- getTyped <$> ask+  traceWith @IOTracer tracer t++throwError :: (VCStoreLogM env m, VCStoreErrM err m) => VCStoreError -> m a+throwError e = do+  trace $ ThrownVCStoreError e+  throwing _Typed e++initVCStore :: VCStoreEnvM env m => m ()+initVCStore =+  (getTyped <$> ask) >>= \(VCStorePath storePath) -> liftIO $ do+    createDirectoryIfMissing True $ storePath </> "heads"+    createDirectoryIfMissing True $ storePath </> "to_head"+    createDirectoryIfMissing True $ storePath </> "deps"++initVCCachedClient :: VCStoreEnvM env m => m ()+initVCCachedClient =+  (getTyped <$> ask) >>= \(VCStorePath storePath) -> liftIO $ do+    createDirectoryIfMissing True $ storePath </> "deps"++checkPathExists :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m ()+checkPathExists 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+  liftIO $ BL.readFile $ path </> show h++appendBS :: (VCStoreLogM env m) => FilePath -> BL.ByteString -> m ()+appendBS fp bs = do+  trace $ WriteTxt fp+  liftIO $ BL.appendFile fp bs++writeBS :: (VCStoreLogM env m) => FilePath -> BL.ByteString -> m ()+writeBS fp bs = do+  trace $ WriteTxt fp+  liftIO $ BL.writeFile fp bs++writeHashedJSON :: (VCStoreLogM env m, VCHashUpdate obj, ToJSON obj) => FilePath -> obj -> m VCObjectHash+writeHashedJSON path o = do+  let h = vcHash o+  exists <- liftIO $ doesFileExist path+  if exists+    then trace $ AlreadyExistsJSON (path </> show h)+    else do+      trace $ WriteJSON (path </> show h)+      liftIO $ BL.writeFile (path </> show h) $ encode o+  pure h++readVCObjectHashTxt :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m [VCObjectHash]+readVCObjectHashTxt fp = do+  checkPathExists 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++storeVCObject :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, VCHashUpdate a, VCHashUpdate g, ToJSON a, ToJSON g) => VCMeta a g VCObject -> m VCObjectHash+storeVCObject obj@VCMeta {obj = ast, pred = p} = do+  VCStorePath storePath <- getTyped <$> ask+  -- if the new object has a direct predecessor (i.e. is not a clone or an initial commit)+  --  we need to make sure that the predecessor is currently a HEAD object in the store+  let maybeCurrentHead = case p of+        Init -> Nothing+        CloneOf _ -> Nothing+        CloneOfRemoved _ -> Nothing+        CloneOfNotFound _ -> Nothing+        CompatibleWithPred h -> Just h+        IncompatibleWithPred h _ -> Just h+        MarkedBreakingWithPred h -> Just h++  obj_h <- case maybeCurrentHead of+    Just pred_hash -> do+      let head_fp = storePath </> "heads" </> show pred_hash+      -- check to see if pred_hash exists in '<storePath>/heads`+      exists_head <- liftIO $ doesFileExist head_fp+      if exists_head+        then do+          -- we know that pred_h is currently HEAD, we can therefore store the object and metadata in the store+          obj_h <- writeHashedJSON storePath obj+          -- next we make the newly added object the HEAD+          let new_head_fp = storePath </> "heads" </> show obj_h+          liftIO $ renameFile head_fp new_head_fp+          -- we append the previous head hash to the file (this serves as lookup for all the predecessors)+          appendBS new_head_fp $ BL.fromStrict $ vcObjectHashToByteString pred_hash <> "\n"+          -- now we need to change all the predecessor mappings in '<storePath>/to_head' to point to the new HEAD+          -- we also include the new head pointing to itself+          preds <- readVCObjectHashTxt new_head_fp+          let obj_h_bs = BL.fromStrict $ vcObjectHashToByteString obj_h+          forM_ (obj_h : preds) $ \pred_h ->+            writeBS (storePath </> "to_head" </> show pred_h) obj_h_bs++          pure obj_h+        else throwError $ TryingToAppendToNonHead pred_hash+    Nothing -> do+      obj_h <- writeHashedJSON storePath obj+      -- as there is no previous HEAD for this object, we simply create a new one+      let new_head_fp = storePath </> "heads" </> show obj_h+      appendBS new_head_fp $ case p of+        -- in case this is a clone of another object, we add its hash to the history+        CloneOf clone_h -> BL.fromStrict $ vcObjectHashToByteString clone_h <> "\n"+        _ -> mempty++      -- we again make sure to add a self reference link to the '<storePath>/to_head' map+      let obj_h_bs = BL.fromStrict $ vcObjectHashToByteString obj_h+      writeBS (storePath </> "to_head" </> show obj_h) obj_h_bs+      pure obj_h++  -- finally, we store the dependencies of the commited object by fetching the dependencies from the AST+  let deps = Set.toList $ getDependencies ast+  writeBS (storePath </> "deps" </> show obj_h) mempty+  forM_ deps $ \dep_h -> do+    -- first we append the direct dependency hash 'dep_h'+    appendBS (storePath </> "deps" </> show obj_h) $ BL.fromStrict $ vcObjectHashToByteString dep_h <> "\n"+    -- then we append the transitive dependencies of the given object, pointed to by the hash 'dep_h'+    appendBS (storePath </> "deps" </> show obj_h) =<< getDepsFromStore (storePath </> "deps") dep_h++  pure obj_h++-- | Delete a temporary object from the VC. This is used for autosaved scripts+-- and to run tests against unsaved scripts+deleteAutosavedVCObject :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => VCObjectHash -> m ()+deleteAutosavedVCObject obj_hash = do+  VCStorePath storePath <- getTyped <$> ask+  -- check if object meta exists with hash meta_hash, and get meta+  (VCMeta {name = obj_name} :: VCMeta Value Value VCObject) <- fetchVCObject obj_hash+  -- check that it is safe to delete+  if obj_name == pack "<AUTOSAVE>"+    then do+      -- delete object, object meta, head/to_head, and deps+      deleteFile $ (storePath </> show obj_hash)+      deleteFile $ (storePath </> "heads" </> show obj_hash)+      deleteFile $ (storePath </> "to_head" </> show obj_hash)+      deleteFile $ (storePath </> "deps" </> show obj_hash)+    else throwError $ TryingToDeleteNonAutosave obj_name+  where+    deleteFile fp = do+      trace $ DeleteFile fp+      liftIO $ removeFile fp++-- | Deletes all stale autosaved objects from the VC.+deleteStaleAutosavedVCObjects :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => m ()+deleteStaleAutosavedVCObjects = do+  -- We know that all autosaves must be heads:+  heads <- getAllHeads+  forM_+    heads+    ( \h -> do+        -- fetch object, check name and timestamp+        (VCMeta {name, timestamp} :: VCMeta Value Value VCObject) <- fetchVCObject h+        now <- liftIO $ CTime . round . toRational <$> getPOSIXTime+        if name == pack "<AUTOSAVE>" && timestamp < now - 60 * 60+          then -- delete the stale ones (> 1hr old)+            deleteAutosavedVCObject h+          else pure ()+    )++-- | Soft delete script and its predecessors+-- All scripts and their references are moved to "removed" directory+deleteVCObjects :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => VCObjectHash -> m ()+deleteVCObjects obj_hash = do+  VCStorePath storePath <- getTyped <$> ask+  liftIO $ do+    createDirectoryIfMissing True $ storePath </> "removed"+    createDirectoryIfMissing True $ storePath </> "removed" </> "heads"+    createDirectoryIfMissing True $ storePath </> "removed" </> "to_head"+    createDirectoryIfMissing True $ storePath </> "removed" </> "deps"++  (metas :: [VCMeta Value Value VCObjectHash]) <- fetchVCObjectHistory obj_hash+  forM_ metas $ \VCMeta {obj = hash} -> do+    forM_+      [ show hash,+        "heads" </> show hash,+        "to_head" </> show hash,+        "deps" </> show hash+      ]+      $ \source_fp -> safeRenameFile (storePath </> source_fp) (storePath </> "removed" </> source_fp)+  where+    safeRenameFile source target = do+      liftIO (doesFileExist source) >>= \case+        False -> pure ()+        True -> liftIO $ renameFile source target++fetchVCObject :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m (VCMeta a g VCObject)+fetchVCObject = fetchVCObject' Nothing++-- | Fetch object from removed directory+fetchRemovedVCObject :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m (VCMeta a g VCObject)+fetchRemovedVCObject = fetchVCObject' (Just "removed")++fetchVCObject' :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => Maybe FilePath -> VCObjectHash -> m (VCMeta a g VCObject)+fetchVCObject' mprefix h = do+  VCStorePath storePath <- getTyped <$> ask+  let fp = case mprefix of+        Nothing -> storePath </> show h+        Just prefix -> storePath </> prefix </> show h+  checkPathExists fp+  trace $ ReadJSON fp+  either (throwError . CouldNotDecodeObject h) pure =<< (liftIO $ eitherDecode <$> BL.readFile fp)++fetchVCObjects :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => [VCObjectHash] -> m (Map.Map VCObjectHash (VCMeta a g VCObject))+fetchVCObjects hs = do+  Map.fromList <$> (forM hs $ \h -> (h,) <$> fetchVCObject h)++fetchVCObjectClosureHashes :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => VCObjectHash -> m [VCObjectHash]+fetchVCObjectClosureHashes h = do+  VCStorePath storePath <- getTyped <$> ask+  let fp = storePath </> "deps" </> show 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))+fetchVCObjectWithClosure h = do+  deps <- fetchVCObjectClosureHashes h+  Map.fromList <$> (forM deps $ \dep -> (dep,) <$> fetchVCObject dep)++calculateMissingVCObjects :: VCStoreEnvM env m => [VCObjectHash] -> m [VCObjectHash]+calculateMissingVCObjects = filterM $ \h -> do+  VCStorePath storePath <- getTyped <$> ask+  not <$> (liftIO $ doesFileExist $ storePath </> show h)++fetchCurrentHead :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => VCObjectHash -> m VCObjectHash+fetchCurrentHead h = do+  VCStorePath storePath <- getTyped <$> ask+  let fp = storePath </> "to_head" </> show h+  exists <- liftIO $ doesFileExist fp+  if exists+    then+      readVCObjectHashTxt fp >>= \case+        [h'] -> pure h'+        _ -> throwError $ CouldNotFindHead h+    else throwError $ CouldNotFindHead h++fetchVCObjectHistory :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m [VCMeta a g VCObjectHash]+fetchVCObjectHistory h = do+  head_h <- fetchCurrentHead h+  VCStorePath storePath <- getTyped <$> ask+  let head_fp = storePath </> "heads" </> show head_h+  preds <- readVCObjectHashTxt head_fp+  -- When we fold the preds, 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.+  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 ([], []) (head_h : preds)+  -- We like to know if the source of the clone still exists. We can do this by checking against the deleted hashes+  -- that we tracked above.+  pure $ case removeds of+    [] -> metas+    _ ->+      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++getAllHeads :: (VCStoreLogM env m, VCStoreEnvM env m) => m [VCObjectHash]+getAllHeads = do+  VCStorePath storePath <- getTyped <$> ask+  headsRaw <- liftIO $ getDirectoryContents $ storePath </> "heads"+  pure $+    foldr+      ( \hd xs ->+          case (either (const $ Nothing) Just $ Base64.decode $ Char8.pack hd) >>= digestFromByteString of+            Just hsh -> (VCObjectHash hsh) : xs+            Nothing -> xs+      )+      []+      (map takeFileName headsRaw)++fetchFunctionsForGroups :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, Ord g, FromJSON a, FromJSON g) => Set.Set g -> m [VCMeta a g VCObjectHash]+fetchFunctionsForGroups grps = do+  heads <- getAllHeads+  foldM+    ( \objs hsh -> do+        meta@VCMeta {obj, visibility, group} <- fetchVCObject hsh+        pure $ case obj of+          VCFunction _ _ ->+            if visibility == VCObjectPublic || group `Set.member` grps+              then (fmap (const hsh) meta) : objs+              else objs+          _ -> objs+    )+    []+    heads
+ src/Inferno/VersionControl/Operations/Error.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveAnyClass #-}++module Inferno.VersionControl.Operations.Error where++import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text, unpack)+import GHC.Generics (Generic)+import Inferno.VersionControl.Types+  ( VCObjectHash (..),+  )++data VCStoreError+  = CouldNotDecodeObject VCObjectHash String+  | CouldNotFindObject VCObjectHash+  | CouldNotFindPath FilePath+  | CouldNotFindHead VCObjectHash+  | TryingToAppendToNonHead VCObjectHash+  | InvalidHash String+  | UnexpectedObjectType VCObjectHash Text+  | TryingToDeleteNonAutosave Text+  deriving (Show, Generic, ToJSON, FromJSON)++vcStoreErrorToString :: VCStoreError -> String+vcStoreErrorToString = \case+  CouldNotDecodeObject h s -> "Could not decode object '" <> show h <> "': " <> s+  CouldNotFindObject h ->+    "Could not find object '" <> show h <> "'"+  CouldNotFindPath fp -> "Could not find path: " <> fp+  CouldNotFindHead h -> "Could not find HEAD for object '" <> show h <> "'"+  TryingToAppendToNonHead h -> "Trying to append to non-HEAD object '" <> show h <> "'"+  InvalidHash s -> "Could not decode hash '" <> s <> "'"+  UnexpectedObjectType h s ->+    "Unexpected object type of '" <> show h <> "'. Was expecting " <> unpack s+  TryingToDeleteNonAutosave n -> "Trying to delete a non-autosaved script " <> unpack n
+ src/Inferno/VersionControl/Server.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Inferno.VersionControl.Server where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (link, withAsync)+import Control.Monad (forever)+import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad.Reader (ReaderT, runReaderT)+import Data.Aeson (FromJSON, ToJSON)+import Data.Functor.Contravariant (contramap)+import qualified Data.Map as Map+import Data.Proxy (Proxy (..))+import Data.Set (Set)+import Data.String (fromString)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Inferno.Types.Syntax (Expr)+import Inferno.Types.Type (TCScheme)+import Inferno.VersionControl.Log (VCServerTrace (ThrownVCStoreError), vcServerTraceToString)+import qualified Inferno.VersionControl.Operations as Ops+import qualified Inferno.VersionControl.Operations.Error as Ops+import Inferno.VersionControl.Server.Types (ServerConfig (..), readServerConfig)+import Inferno.VersionControl.Server.UnzipRequest (ungzipRequest)+import Inferno.VersionControl.Types+  ( Pinned,+    VCHashUpdate,+    VCMeta (..),+    VCObject (..),+    VCObjectHash,+    showVCObjectType,+  )+import Network.Wai.Handler.Warp+  ( defaultSettings,+    runSettings,+    setHost,+    setPort,+    setTimeout,+  )+import Network.Wai.Middleware.Gzip (def, gzip)+import Plow.Logging (IOTracer (..), simpleStdOutTracer, traceWith)+import Servant.API (Capture, JSON, ReqBody, Union, (:<|>) (..), (:>))+import Servant.Server (Handler, Server, serve)+import Servant.Typed.Error+  ( DeleteTypedError,+    GetTypedError,+    PostTypedError,+    WithError,+    liftTypedError,+  )++newtype VCServerError = VCServerError {serverError :: Ops.VCStoreError}+  deriving (Generic, Show)+  deriving newtype (ToJSON, FromJSON)++type GetThrowingVCStoreError resp ty = GetTypedError resp ty VCServerError++type PostThrowingVCStoreError resp ty = PostTypedError resp ty VCServerError++type DeleteThrowingVCStoreError resp ty = DeleteTypedError resp ty VCServerError++type VersionControlAPI a g =+  "fetch" :> "function" :> Capture "hash" VCObjectHash :> GetThrowingVCStoreError '[JSON] (VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme))+    :<|> "fetch" :> "functions" :> ReqBody '[JSON] (Set g) :> PostThrowingVCStoreError '[JSON] [VCMeta a g VCObjectHash]+    :<|> "fetch" :> Capture "hash" VCObjectHash :> GetThrowingVCStoreError '[JSON] (VCMeta a g VCObject)+    :<|> "fetch" :> Capture "hash" VCObjectHash :> "history" :> GetThrowingVCStoreError '[JSON] [VCMeta a g VCObjectHash]+    :<|> "fetch" :> "objects" :> ReqBody '[JSON] [VCObjectHash] :> PostThrowingVCStoreError '[JSON] (Map.Map VCObjectHash (VCMeta a g VCObject))+    :<|> "fetch" :> "object" :> Capture "hash" VCObjectHash :> "closure" :> "hashes" :> GetThrowingVCStoreError '[JSON] [VCObjectHash]+    :<|> "push" :> "function" :> ReqBody '[JSON] (VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme)) :> PostThrowingVCStoreError '[JSON] VCObjectHash+    :<|> "delete" :> "autosave" :> "function" :> ReqBody '[JSON] VCObjectHash :> DeleteThrowingVCStoreError '[JSON] ()+    :<|> "delete" :> "scripts" :> Capture "hash" VCObjectHash :> DeleteThrowingVCStoreError '[JSON] ()++vcServer :: (VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a, ToJSON g, Ord g) => FilePath -> IOTracer VCServerTrace -> Server (VersionControlAPI a g)+vcServer config tracer =+  toHandler . fetchFunctionH+    :<|> toHandler . Ops.fetchFunctionsForGroups+    :<|> toHandler . Ops.fetchVCObject+    :<|> toHandler . Ops.fetchVCObjectHistory+    :<|> toHandler . Ops.fetchVCObjects+    :<|> toHandler . Ops.fetchVCObjectClosureHashes+    :<|> toHandler . pushFunctionH+    :<|> toHandler . Ops.deleteAutosavedVCObject+    :<|> toHandler . Ops.deleteVCObjects+  where+    fetchFunctionH h = do+      om@VCMeta {obj} <- Ops.fetchVCObject h+      case obj of+        VCFunction f t -> pure om {obj = (f, t)}+        _ -> Ops.throwError $ Ops.UnexpectedObjectType h $ showVCObjectType obj++    pushFunctionH meta@VCMeta {obj = (f, t)} = Ops.storeVCObject meta {obj = VCFunction f t}++    toHandler :: ReaderT (Ops.VCStorePath, IOTracer VCServerTrace) (ExceptT VCServerError Handler) a -> Handler (Union (WithError VCServerError a))+    toHandler = liftTypedError . flip runReaderT (Ops.VCStorePath config, tracer)++runServer :: forall proxy a g. (VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a, ToJSON g, Ord g) => proxy a -> proxy g -> IO ()+runServer proxyA proxyG = do+  readServerConfig "config.yml" >>= \case+    Left err -> putStrLn err+    Right serverConfig -> runServerConfig proxyA proxyG serverConfig++runServerConfig :: forall proxy a g. (VCHashUpdate a, VCHashUpdate g, FromJSON a, FromJSON g, ToJSON a, ToJSON g, Ord g) => proxy a -> proxy g -> ServerConfig -> IO ()+runServerConfig _ _ serverConfig = do+  let host = fromString . T.unpack . _serverHost $ serverConfig+      port = _serverPort serverConfig+      vcPath = _vcPath serverConfig+      settingsWithTimeout = setTimeout 300 defaultSettings+      tracer = contramap vcServerTraceToString $ IOTracer $ simpleStdOutTracer+      deleteOp = Ops.deleteStaleAutosavedVCObjects :: ReaderT (Ops.VCStorePath, IOTracer VCServerTrace) (ExceptT VCServerError IO) ()+      cleanup =+        (runExceptT $ flip runReaderT (Ops.VCStorePath vcPath, tracer) deleteOp) >>= \case+          Left (VCServerError {serverError}) ->+            traceWith @IOTracer tracer (ThrownVCStoreError serverError)+          Right _ -> pure ()++  runReaderT Ops.initVCStore $ Ops.VCStorePath vcPath+  print ("running..." :: String)+  -- Cleanup stale autosave scripts in a separate thread every hour:+  withLinkedAsync_ (forever $ threadDelay 3600000000 >> cleanup) $+    -- And run the server:+    runSettings (setPort port $ setHost host settingsWithTimeout) $+      ungzipRequest $+        gzip def $+          serve (Proxy :: Proxy (VersionControlAPI a g)) $ vcServer vcPath tracer++withLinkedAsync_ :: IO a -> IO b -> IO b+withLinkedAsync_ f g = withAsync f $ \h -> link h >> g
+ src/Inferno/VersionControl/Server/Types.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module Inferno.VersionControl.Server.Types where++import Data.Aeson.Types+import Data.ByteString (readFile)+import Data.Text (Text)+import Data.Yaml++data ServerConfig = ServerConfig+  { _serverHost :: Text,+    _serverPort :: Int,+    _vcPath :: FilePath+  }+  deriving (Show, Eq, Ord)++instance FromJSON ServerConfig where+  parseJSON = withObject "ServerConfig" $ \o -> do+    server <- o .: "server"+    serverHost <- server .: "host"+    serverPort <- server .: "port"+    vcPath <- server .: "vcPath"++    return $ ServerConfig serverHost serverPort vcPath++readServerConfig ::+  FilePath ->+  IO (Either String ServerConfig)+readServerConfig fp = do+  f <- Data.ByteString.readFile fp+  return $ either (Left . prettyPrintParseException) Right $ decodeEither' f
+ src/Inferno/VersionControl/Server/UnzipRequest.hs view
@@ -0,0 +1,24 @@+-- copy of all/alarm/alarm-log-server-chronicle/app/UnzipRequest.hs+{-# LANGUAGE OverloadedStrings #-}+-- See module description for the reasong for ignoring deprecations.+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Quarantines a function that uses a deprecated requestBody field.+-- We use Network.Wai's requestBody to create a response but it is deprecated.+-- But we are using it for the same purpose as they are, and they disable deprecations to work around their own deprecated field, so we do the same.+-- See https://github.com/yesodweb/wai/blob/e15f41ba20dbd94b511048692541ca89117f1f7c/wai/Network/Wai.hs#L34-L35+module Inferno.VersionControl.Server.UnzipRequest where++import Codec.Compression.GZip (decompress)+import qualified Data.ByteString.Lazy as BL+import Network.Wai++ungzipRequest :: Middleware+ungzipRequest app req = app req'+  where+    req'+      | Just "gzip" <- lookup "Content-encoding" (requestHeaders req) = go req+      | otherwise = req+    go r = r {requestBody = decompressNonEmpty <$> (strictRequestBody r)}+    decompressNonEmpty "" = "" -- Necessary 'cause the IO gets pulled until requestBody gives ""+    decompressNonEmpty x = BL.toStrict . decompress $ x
+ src/Inferno/VersionControl/Types.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++module Inferno.VersionControl.Types+  ( VCObjectHash (..),+    VCObject (..),+    VCObjectVisibility (..),+    VCMeta (..),+    VCCommitMessage (..),+    VCIncompatReason (..),+    VCObjectPred (..),+    VCHashUpdate (..),+    Pinned (..),+    vcObjectHashToByteString,+    vcHash,+    showVCObjectType,+  )+where++import Data.Aeson (FromJSON, ToJSON)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Foreign.C.Types (CTime)+import GHC.Generics (Generic)+import Inferno.Types.Module (Module (..))+import Inferno.Types.Syntax (Dependencies (..), Expr (..), Ident (..))+import Inferno.Types.Type (Namespace, TCScheme (..)) -- TypeMetadata(..),+import Inferno.Types.VersionControl (Pinned (..), VCHashUpdate (..), VCObjectHash (..), pinnedUnderVCToMaybe, vcHash, vcObjectHashToByteString)+import Test.QuickCheck (Arbitrary (..), oneof)+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary)+import Test.QuickCheck.Instances.Text ()++data VCObject+  = VCModule (Module (Map Ident VCObjectHash))+  | VCFunction (Expr (Pinned VCObjectHash) ()) TCScheme -- (Map (SourcePos, SourcePos) (TypeMetadata TCScheme))+  | VCTestFunction (Expr (Pinned VCObjectHash) ())+  | VCEnum Ident (Set Ident)+  deriving (Eq, Generic, ToJSON, FromJSON, VCHashUpdate)++showVCObjectType :: VCObject -> Text+showVCObjectType = \case+  VCModule _ -> "module"+  VCFunction _ _ -> "function"+  VCTestFunction _ -> "test function"+  VCEnum _ _ -> "enum"++instance Dependencies VCObject VCObjectHash where+  getDependencies = \case+    VCModule Module {moduleObjects = os} -> Set.fromList $ Map.elems os+    VCFunction expr _ -> Set.fromList $ catMaybes $ map pinnedUnderVCToMaybe $ Set.toList $ getDependencies expr+    VCTestFunction expr -> Set.fromList $ catMaybes $ map pinnedUnderVCToMaybe $ Set.toList $ getDependencies expr+    VCEnum _ _ -> mempty++data VCObjectVisibility = VCObjectPublic | VCObjectPrivate deriving (Show, Eq, Generic, ToJSON, FromJSON, VCHashUpdate)++instance Arbitrary VCObjectVisibility where+  arbitrary = oneof $ map pure [VCObjectPublic, VCObjectPrivate]++deriving instance ToADTArbitrary VCObjectVisibility++newtype VCCommitMessage = VCCommitMessage {unVCCommitMessage :: Text}+  deriving stock (Show, Eq, Generic)+  deriving newtype (ToJSON, FromJSON, VCHashUpdate)++data VCIncompatReason+  = TypeSignatureChange+  | EnumConstructorsChanged+  deriving (Show, Eq, Generic, ToJSON, FromJSON, VCHashUpdate)++instance Arbitrary VCIncompatReason where+  arbitrary = oneof $ map pure [TypeSignatureChange, EnumConstructorsChanged]++deriving instance ToADTArbitrary VCIncompatReason++data VCObjectPred+  = -- | Original script (root of the histories).+    Init+  | CompatibleWithPred VCObjectHash+  | IncompatibleWithPred VCObjectHash [(Namespace, VCIncompatReason)]+  | MarkedBreakingWithPred VCObjectHash+  | -- | Similar to 'Init' but this script is init'd by cloning the original script.+    CloneOf VCObjectHash+  | -- | CloneOfRemoved' is a "virtual" constructor to differentiate that the source of the script has been removed (but can+    -- still be found in removed directory). However, in the DB the field is still stored as 'CloneOf'. When we build the histories+    -- of a script, it will be differentiated between these 3 constructors for cloned script.+    CloneOfRemoved VCObjectHash+  | -- | 'CloneOfNotFound' is similar to 'CloneOfRemoved' but it is for case where the original script is not found+    -- i.e. the removed folder might get cleared so we lost the original script information.+    CloneOfNotFound VCObjectHash+  deriving (Show, Eq, Generic, ToJSON, FromJSON, VCHashUpdate)++instance Arbitrary VCObjectPred where+  arbitrary =+    oneof+      [ pure Init,+        CompatibleWithPred <$> arbitrary,+        IncompatibleWithPred <$> arbitrary <*> arbitrary,+        MarkedBreakingWithPred <$> arbitrary,+        CloneOf <$> arbitrary+      ]++deriving instance ToADTArbitrary VCObjectPred++-- the owner information and commit messages will be added in further revisions with other metadata as needed+data VCMeta author group o = VCMeta+  { timestamp :: CTime,+    author :: author,+    group :: group,+    name :: Text,+    description :: Text,+    pred :: VCObjectPred,+    -- commitMessage :: VCCommitMessage,+    visibility :: VCObjectVisibility,+    obj :: o+  }+  deriving (Show, Eq, Functor, Generic, ToJSON, FromJSON, VCHashUpdate)++instance (Arbitrary a, Arbitrary g, Arbitrary o) => Arbitrary (VCMeta a g o) where+  arbitrary =+    VCMeta+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary++deriving instance (Arbitrary a, Arbitrary g, Arbitrary o) => ToADTArbitrary (VCMeta a g o)