diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Revision History for inferno-vc + +## 0.1.0.0 -- 2022-11-28 +* Prepare for OSS release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/inferno-vc.cabal b/inferno-vc.cabal new file mode 100644 --- /dev/null +++ b/inferno-vc.cabal @@ -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 diff --git a/src/Inferno/VersionControl/Client.hs b/src/Inferno/VersionControl/Client.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Client.hs @@ -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 diff --git a/src/Inferno/VersionControl/Client/Cached.hs b/src/Inferno/VersionControl/Client/Cached.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Client/Cached.hs @@ -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 diff --git a/src/Inferno/VersionControl/Log.hs b/src/Inferno/VersionControl/Log.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Log.hs @@ -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 diff --git a/src/Inferno/VersionControl/Operations.hs b/src/Inferno/VersionControl/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Operations.hs @@ -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: +-- +-- * `` stores the JSON serialised `VCMeta VCObject`s, where the filename is the cryptographic hash (`VCOBjectHash`) of the object's contents +-- * `/heads` is a set of current HEAD objects of the store, which can be seen as the roots of the VC tree +-- * `/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 +-- * `/deps` is a map from every `VCOBjectHash` to its (transitive) dependencies, i.e. the file `/deps/` describes the closure of `` +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 '/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 '/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 '/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 "" + 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 "" && 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 diff --git a/src/Inferno/VersionControl/Operations/Error.hs b/src/Inferno/VersionControl/Operations/Error.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Operations/Error.hs @@ -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 diff --git a/src/Inferno/VersionControl/Server.hs b/src/Inferno/VersionControl/Server.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Server.hs @@ -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 diff --git a/src/Inferno/VersionControl/Server/Types.hs b/src/Inferno/VersionControl/Server/Types.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Server/Types.hs @@ -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 diff --git a/src/Inferno/VersionControl/Server/UnzipRequest.hs b/src/Inferno/VersionControl/Server/UnzipRequest.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Server/UnzipRequest.hs @@ -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 diff --git a/src/Inferno/VersionControl/Types.hs b/src/Inferno/VersionControl/Types.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/VersionControl/Types.hs @@ -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)