{-# 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 (forall x. Rep VCStorePath x -> VCStorePath
forall x. VCStorePath -> Rep VCStorePath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VCStorePath x -> VCStorePath
$cfrom :: forall x. VCStorePath -> Rep VCStorePath x
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 :: forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace VCServerTrace
t = do
  IOTracer VCServerTrace
tracer <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (x :: * -> *) (m :: * -> *) a.
TraceWith x m =>
x a -> a -> m ()
traceWith @IOTracer IOTracer VCServerTrace
tracer VCServerTrace
t

throwError :: (VCStoreLogM env m, VCStoreErrM err m) => VCStoreError -> m a
throwError :: forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError VCStoreError
e = do
  forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ VCStoreError -> VCServerTrace
ThrownVCStoreError VCStoreError
e
  forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall a s. AsType a s => Prism' s a
_Typed VCStoreError
e

initVCStore :: VCStoreEnvM env m => m ()
initVCStore :: forall env (m :: * -> *). VCStoreEnvM env m => m ()
initVCStore =
  (forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(VCStorePath FilePath
storePath) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"to_head"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps"

initVCCachedClient :: VCStoreEnvM env m => m ()
initVCCachedClient :: forall env (m :: * -> *). VCStoreEnvM env m => m ()
initVCCachedClient =
  (forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(VCStorePath FilePath
storePath) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps"

checkPathExists :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m ()
checkPathExists :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m ()
checkPathExists FilePath
fp =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
fp) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ FilePath -> VCStoreError
CouldNotFindPath FilePath
fp
    Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getDepsFromStore :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> VCObjectHash -> m BL.ByteString
getDepsFromStore :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> VCObjectHash -> m ByteString
getDepsFromStore FilePath
path VCObjectHash
h = do
  let fp :: FilePath
fp = FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h
  forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m ()
checkPathExists FilePath
fp
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BL.readFile forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h

appendBS :: (VCStoreLogM env m) => FilePath -> BL.ByteString -> m ()
appendBS :: forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
appendBS FilePath
fp ByteString
bs = do
  forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
WriteTxt FilePath
fp
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BL.appendFile FilePath
fp ByteString
bs

writeBS :: (VCStoreLogM env m) => FilePath -> BL.ByteString -> m ()
writeBS :: forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
writeBS FilePath
fp ByteString
bs = do
  forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
WriteTxt FilePath
fp
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BL.writeFile FilePath
fp ByteString
bs

writeHashedJSON :: (VCStoreLogM env m, VCHashUpdate obj, ToJSON obj) => FilePath -> obj -> m VCObjectHash
writeHashedJSON :: forall env (m :: * -> *) obj.
(VCStoreLogM env m, VCHashUpdate obj, ToJSON obj) =>
FilePath -> obj -> m VCObjectHash
writeHashedJSON FilePath
path obj
o = do
  let h :: VCObjectHash
h = forall obj. VCHashUpdate obj => obj -> VCObjectHash
vcHash obj
o
  Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
path
  if Bool
exists
    then forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
AlreadyExistsJSON (FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h)
    else do
      forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
WriteJSON (FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BL.writeFile (FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h) forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode obj
o
  forall (f :: * -> *) a. Applicative f => a -> f a
pure VCObjectHash
h

readVCObjectHashTxt :: (VCStoreLogM env m, VCStoreErrM err m) => FilePath -> m [VCObjectHash]
readVCObjectHashTxt :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m [VCObjectHash]
readVCObjectHashTxt FilePath
fp = do
  forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m ()
checkPathExists FilePath
fp
  forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
ReadTxt FilePath
fp
  [ByteString]
deps <- forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
Char8.lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
B.readFile FilePath
fp)
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ByteString]
deps forall a b. (a -> b) -> a -> b
$ \ByteString
dep -> do
    ByteString
decoded <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ FilePath -> VCStoreError
InvalidHash forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
Char8.unpack ByteString
dep) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath ByteString
Base64.decode ByteString
dep
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ FilePath -> VCStoreError
InvalidHash forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
Char8.unpack ByteString
dep) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> VCObjectHash
VCObjectHash) forall a b. (a -> b) -> a -> b
$ forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString ByteString
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 :: forall env (m :: * -> *) err a g.
(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 a g VCObject
obj@VCMeta {obj :: forall author group o. VCMeta author group o -> o
obj = VCObject
ast, pred :: forall author group o. VCMeta author group o -> VCObjectPred
pred = VCObjectPred
p} = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
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 :: Maybe VCObjectHash
maybeCurrentHead = case VCObjectPred
p of
        VCObjectPred
Init -> forall a. Maybe a
Nothing
        CloneOf VCObjectHash
_ -> forall a. Maybe a
Nothing
        CloneOfRemoved VCObjectHash
_ -> forall a. Maybe a
Nothing
        CloneOfNotFound VCObjectHash
_ -> forall a. Maybe a
Nothing
        CompatibleWithPred VCObjectHash
h -> forall a. a -> Maybe a
Just VCObjectHash
h
        IncompatibleWithPred VCObjectHash
h [(Namespace, VCIncompatReason)]
_ -> forall a. a -> Maybe a
Just VCObjectHash
h
        MarkedBreakingWithPred VCObjectHash
h -> forall a. a -> Maybe a
Just VCObjectHash
h

  VCObjectHash
obj_h <- case Maybe VCObjectHash
maybeCurrentHead of
    Just VCObjectHash
pred_hash -> do
      let head_fp :: FilePath
head_fp = FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
pred_hash
      -- check to see if pred_hash exists in '<storePath>/heads`
      Bool
exists_head <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
head_fp
      if Bool
exists_head
        then do
          -- we know that pred_h is currently HEAD, we can therefore store the object and metadata in the store
          VCObjectHash
obj_h <- forall env (m :: * -> *) obj.
(VCStoreLogM env m, VCHashUpdate obj, ToJSON obj) =>
FilePath -> obj -> m VCObjectHash
writeHashedJSON FilePath
storePath VCMeta a g VCObject
obj
          -- next we make the newly added object the HEAD
          let new_head_fp :: FilePath
new_head_fp = FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_h
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile FilePath
head_fp FilePath
new_head_fp
          -- we append the previous head hash to the file (this serves as lookup for all the predecessors)
          forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
appendBS FilePath
new_head_fp forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ VCObjectHash -> ByteString
vcObjectHashToByteString VCObjectHash
pred_hash forall a. Semigroup a => a -> a -> a
<> ByteString
"\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
          [VCObjectHash]
preds <- forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m [VCObjectHash]
readVCObjectHashTxt FilePath
new_head_fp
          let obj_h_bs :: ByteString
obj_h_bs = ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ VCObjectHash -> ByteString
vcObjectHashToByteString VCObjectHash
obj_h
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (VCObjectHash
obj_h forall a. a -> [a] -> [a]
: [VCObjectHash]
preds) forall a b. (a -> b) -> a -> b
$ \VCObjectHash
pred_h ->
            forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
writeBS (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"to_head" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
pred_h) ByteString
obj_h_bs

          forall (f :: * -> *) a. Applicative f => a -> f a
pure VCObjectHash
obj_h
        else forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ VCObjectHash -> VCStoreError
TryingToAppendToNonHead VCObjectHash
pred_hash
    Maybe VCObjectHash
Nothing -> do
      VCObjectHash
obj_h <- forall env (m :: * -> *) obj.
(VCStoreLogM env m, VCHashUpdate obj, ToJSON obj) =>
FilePath -> obj -> m VCObjectHash
writeHashedJSON FilePath
storePath VCMeta a g VCObject
obj
      -- as there is no previous HEAD for this object, we simply create a new one
      let new_head_fp :: FilePath
new_head_fp = FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_h
      forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
appendBS FilePath
new_head_fp forall a b. (a -> b) -> a -> b
$ case VCObjectPred
p of
        -- in case this is a clone of another object, we add its hash to the history
        CloneOf VCObjectHash
clone_h -> ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ VCObjectHash -> ByteString
vcObjectHashToByteString VCObjectHash
clone_h forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
        VCObjectPred
_ -> forall a. Monoid a => a
mempty

      -- we again make sure to add a self reference link to the '<storePath>/to_head' map
      let obj_h_bs :: ByteString
obj_h_bs = ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ VCObjectHash -> ByteString
vcObjectHashToByteString VCObjectHash
obj_h
      forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
writeBS (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"to_head" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_h) ByteString
obj_h_bs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure VCObjectHash
obj_h

  -- finally, we store the dependencies of the commited object by fetching the dependencies from the AST
  let deps :: [VCObjectHash]
deps = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall f hash. (Dependencies f hash, Ord hash) => f -> Set hash
getDependencies VCObject
ast
  forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
writeBS (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_h) forall a. Monoid a => a
mempty
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VCObjectHash]
deps forall a b. (a -> b) -> a -> b
$ \VCObjectHash
dep_h -> do
    -- first we append the direct dependency hash 'dep_h'
    forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
appendBS (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_h) forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict forall a b. (a -> b) -> a -> b
$ VCObjectHash -> ByteString
vcObjectHashToByteString VCObjectHash
dep_h forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
    -- then we append the transitive dependencies of the given object, pointed to by the hash 'dep_h'
    forall env (m :: * -> *).
VCStoreLogM env m =>
FilePath -> ByteString -> m ()
appendBS (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_h) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> VCObjectHash -> m ByteString
getDepsFromStore (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps") VCObjectHash
dep_h

  forall (f :: * -> *) a. Applicative f => a -> f a
pure VCObjectHash
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 :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m ()
deleteAutosavedVCObject VCObjectHash
obj_hash = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  -- check if object meta exists with hash meta_hash, and get meta
  (VCMeta {name :: forall author group o. VCMeta author group o -> Text
name = Text
obj_name} :: VCMeta Value Value VCObject) <- forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject VCObjectHash
obj_hash
  -- check that it is safe to delete
  if Text
obj_name forall a. Eq a => a -> a -> Bool
== FilePath -> Text
pack FilePath
"<AUTOSAVE>"
    then do
      -- delete object, object meta, head/to_head, and deps
      forall {m :: * -> *} {env}.
(HasType (IOTracer VCServerTrace) env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
deleteFile forall a b. (a -> b) -> a -> b
$ (FilePath
storePath FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_hash)
      forall {m :: * -> *} {env}.
(HasType (IOTracer VCServerTrace) env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
deleteFile forall a b. (a -> b) -> a -> b
$ (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_hash)
      forall {m :: * -> *} {env}.
(HasType (IOTracer VCServerTrace) env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
deleteFile forall a b. (a -> b) -> a -> b
$ (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"to_head" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_hash)
      forall {m :: * -> *} {env}.
(HasType (IOTracer VCServerTrace) env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
deleteFile forall a b. (a -> b) -> a -> b
$ (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
obj_hash)
    else forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> VCStoreError
TryingToDeleteNonAutosave Text
obj_name
  where
    deleteFile :: FilePath -> m ()
deleteFile FilePath
fp = do
      forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
DeleteFile FilePath
fp
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
fp

-- | Deletes all stale autosaved objects from the VC.
deleteStaleAutosavedVCObjects :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => m ()
deleteStaleAutosavedVCObjects :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
m ()
deleteStaleAutosavedVCObjects = do
  -- We know that all autosaves must be heads:
  [VCObjectHash]
heads <- forall env (m :: * -> *).
(VCStoreLogM env m, VCStoreEnvM env m) =>
m [VCObjectHash]
getAllHeads
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
    [VCObjectHash]
heads
    ( \VCObjectHash
h -> do
        -- fetch object, check name and timestamp
        (VCMeta {Text
name :: Text
name :: forall author group o. VCMeta author group o -> Text
name, CTime
timestamp :: forall author group o. VCMeta author group o -> CTime
timestamp :: CTime
timestamp} :: VCMeta Value Value VCObject) <- forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject VCObjectHash
h
        CTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int64 -> CTime
CTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
        if Text
name forall a. Eq a => a -> a -> Bool
== FilePath -> Text
pack FilePath
"<AUTOSAVE>" Bool -> Bool -> Bool
&& CTime
timestamp forall a. Ord a => a -> a -> Bool
< CTime
now forall a. Num a => a -> a -> a
- CTime
60 forall a. Num a => a -> a -> a
* CTime
60
          then -- delete the stale ones (> 1hr old)
            forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m ()
deleteAutosavedVCObject VCObjectHash
h
          else forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m ()
deleteVCObjects VCObjectHash
obj_hash = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"removed"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"removed" FilePath -> FilePath -> FilePath
</> FilePath
"heads"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"removed" FilePath -> FilePath -> FilePath
</> FilePath
"to_head"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"removed" FilePath -> FilePath -> FilePath
</> FilePath
"deps"

  ([VCMeta Value Value VCObjectHash]
metas :: [VCMeta Value Value VCObjectHash]) <- forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m [VCMeta a g VCObjectHash]
fetchVCObjectHistory VCObjectHash
obj_hash
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VCMeta Value Value VCObjectHash]
metas forall a b. (a -> b) -> a -> b
$ \VCMeta {obj :: forall author group o. VCMeta author group o -> o
obj = VCObjectHash
hash} -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
      [ forall a. Show a => a -> FilePath
show VCObjectHash
hash,
        FilePath
"heads" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
hash,
        FilePath
"to_head" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
hash,
        FilePath
"deps" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
hash
      ]
      forall a b. (a -> b) -> a -> b
$ \FilePath
source_fp -> forall {m :: * -> *}. MonadIO m => FilePath -> FilePath -> m ()
safeRenameFile (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
source_fp) (FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"removed" FilePath -> FilePath -> FilePath
</> FilePath
source_fp)
  where
    safeRenameFile :: FilePath -> FilePath -> m ()
safeRenameFile FilePath
source FilePath
target = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
source) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Bool
True -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile FilePath
source FilePath
target

fetchVCObject :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject :: forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject = forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
Maybe FilePath -> VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject' forall a. Maybe a
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 :: forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchRemovedVCObject = forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
Maybe FilePath -> VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject' (forall a. a -> Maybe a
Just FilePath
"removed")

fetchVCObject' :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => Maybe FilePath -> VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject' :: forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
Maybe FilePath -> VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject' Maybe FilePath
mprefix VCObjectHash
h = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  let fp :: FilePath
fp = case Maybe FilePath
mprefix of
        Maybe FilePath
Nothing -> FilePath
storePath FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h
        Just FilePath
prefix -> FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
prefix FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h
  forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m ()
checkPathExists FilePath
fp
  forall env (m :: * -> *).
VCStoreLogM env m =>
VCServerTrace -> m ()
trace forall a b. (a -> b) -> a -> b
$ FilePath -> VCServerTrace
ReadJSON FilePath
fp
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. VCObjectHash -> FilePath -> VCStoreError
CouldNotDecodeObject VCObjectHash
h) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BL.readFile FilePath
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 :: forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
[VCObjectHash] -> m (Map VCObjectHash (VCMeta a g VCObject))
fetchVCObjects [VCObjectHash]
hs = do
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VCObjectHash]
hs forall a b. (a -> b) -> a -> b
$ \VCObjectHash
h -> (VCObjectHash
h,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject VCObjectHash
h)

fetchVCObjectClosureHashes :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => VCObjectHash -> m [VCObjectHash]
fetchVCObjectClosureHashes :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m [VCObjectHash]
fetchVCObjectClosureHashes VCObjectHash
h = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  let fp :: FilePath
fp = FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"deps" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h
  forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m [VCObjectHash]
readVCObjectHashTxt FilePath
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 :: forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (Map VCObjectHash (VCMeta a g VCObject))
fetchVCObjectWithClosure VCObjectHash
h = do
  [VCObjectHash]
deps <- forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m [VCObjectHash]
fetchVCObjectClosureHashes VCObjectHash
h
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VCObjectHash]
deps forall a b. (a -> b) -> a -> b
$ \VCObjectHash
dep -> (VCObjectHash
dep,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject VCObjectHash
dep)

calculateMissingVCObjects :: VCStoreEnvM env m => [VCObjectHash] -> m [VCObjectHash]
calculateMissingVCObjects :: forall env (m :: * -> *).
VCStoreEnvM env m =>
[VCObjectHash] -> m [VCObjectHash]
calculateMissingVCObjects = forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall a b. (a -> b) -> a -> b
$ \VCObjectHash
h -> do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h)

fetchCurrentHead :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) => VCObjectHash -> m VCObjectHash
fetchCurrentHead :: forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m VCObjectHash
fetchCurrentHead VCObjectHash
h = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  let fp :: FilePath
fp = FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"to_head" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
h
  Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fp
  if Bool
exists
    then
      forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m [VCObjectHash]
readVCObjectHashTxt FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [VCObjectHash
h'] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure VCObjectHash
h'
        [VCObjectHash]
_ -> forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ VCObjectHash -> VCStoreError
CouldNotFindHead VCObjectHash
h
    else forall env (m :: * -> *) err a.
(VCStoreLogM env m, VCStoreErrM err m) =>
VCStoreError -> m a
throwError forall a b. (a -> b) -> a -> b
$ VCObjectHash -> VCStoreError
CouldNotFindHead VCObjectHash
h

fetchVCObjectHistory :: (VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, FromJSON a, FromJSON g) => VCObjectHash -> m [VCMeta a g VCObjectHash]
fetchVCObjectHistory :: forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m [VCMeta a g VCObjectHash]
fetchVCObjectHistory VCObjectHash
h = do
  VCObjectHash
head_h <- forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m VCObjectHash
fetchCurrentHead VCObjectHash
h
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  let head_fp :: FilePath
head_fp = FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
head_h
  [VCObjectHash]
preds <- forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m) =>
FilePath -> m [VCObjectHash]
readVCObjectHashTxt FilePath
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 :: ([VCMeta a g VCObjectHash], [VCObjectHash])
-> VCObjectHash -> m ([VCMeta a g VCObjectHash], [VCObjectHash])
f ([VCMeta a g VCObjectHash], [VCObjectHash])
acc VCObjectHash
hsh = do
        Bool
existsInRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
hsh
        Bool
existsInRemoved <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"removed" FilePath -> FilePath -> FilePath
</> forall a. Show a => a -> FilePath
show VCObjectHash
hsh

        if Bool
existsInRoot
          then do
            VCMeta a g VCObjectHash
obj <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const VCObjectHash
hsh) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject VCObjectHash
hsh
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VCMeta a g VCObjectHash
obj forall a. a -> [a] -> [a]
: forall a b. (a, b) -> a
fst ([VCMeta a g VCObjectHash], [VCObjectHash])
acc), forall a b. (a, b) -> b
snd ([VCMeta a g VCObjectHash], [VCObjectHash])
acc)
          else do
            if Bool
existsInRemoved
              then do
                VCMeta a g VCObjectHash
obj <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const VCObjectHash
hsh) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchRemovedVCObject VCObjectHash
hsh
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VCMeta a g VCObjectHash
obj forall a. a -> [a] -> [a]
: forall a b. (a, b) -> a
fst ([VCMeta a g VCObjectHash], [VCObjectHash])
acc), (VCObjectHash
hsh forall a. a -> [a] -> [a]
: forall a b. (a, b) -> b
snd ([VCMeta a g VCObjectHash], [VCObjectHash])
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.
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VCMeta a g VCObjectHash], [VCObjectHash])
acc
  ([VCMeta a g VCObjectHash]
metas, [VCObjectHash]
removeds) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {err} {m :: * -> *} {env} {a} {g}.
(MonadError err m, AsType VCStoreError err,
 HasType (IOTracer VCServerTrace) env, HasType VCStorePath env,
 MonadIO m, FromJSON a, FromJSON g, MonadReader env m) =>
([VCMeta a g VCObjectHash], [VCObjectHash])
-> VCObjectHash -> m ([VCMeta a g VCObjectHash], [VCObjectHash])
f ([], []) (VCObjectHash
head_h forall a. a -> [a] -> [a]
: [VCObjectHash]
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.
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case [VCObjectHash]
removeds of
    [] -> [VCMeta a g VCObjectHash]
metas
    [VCObjectHash]
_ ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( \VCMeta a g VCObjectHash
meta -> case forall author group o. VCMeta author group o -> VCObjectPred
Inferno.VersionControl.Types.pred VCMeta a g VCObjectHash
meta of
            CloneOf VCObjectHash
hsh'
              | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
List.elem VCObjectHash
hsh' [VCObjectHash]
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.
                VCMeta a g VCObjectHash
meta {pred :: VCObjectPred
Inferno.VersionControl.Types.pred = VCObjectHash -> VCObjectPred
CloneOfRemoved VCObjectHash
hsh'}
            VCObjectPred
_ -> VCMeta a g VCObjectHash
meta
        )
        [VCMeta a g VCObjectHash]
metas

getAllHeads :: (VCStoreLogM env m, VCStoreEnvM env m) => m [VCObjectHash]
getAllHeads :: forall env (m :: * -> *).
(VCStoreLogM env m, VCStoreEnvM env m) =>
m [VCObjectHash]
getAllHeads = do
  VCStorePath FilePath
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  [FilePath]
headsRaw <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents forall a b. (a -> b) -> a -> b
$ FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
"heads"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ( \FilePath
hd [VCObjectHash]
xs ->
          case (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath ByteString
Base64.decode forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
Char8.pack FilePath
hd) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString of
            Just Digest SHA256
hsh -> (Digest SHA256 -> VCObjectHash
VCObjectHash Digest SHA256
hsh) forall a. a -> [a] -> [a]
: [VCObjectHash]
xs
            Maybe (Digest SHA256)
Nothing -> [VCObjectHash]
xs
      )
      []
      (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
takeFileName [FilePath]
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 :: forall env (m :: * -> *) err g a.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m, Ord g,
 FromJSON a, FromJSON g) =>
Set g -> m [VCMeta a g VCObjectHash]
fetchFunctionsForGroups Set g
grps = do
  [VCObjectHash]
heads <- forall env (m :: * -> *).
(VCStoreLogM env m, VCStoreEnvM env m) =>
m [VCObjectHash]
getAllHeads
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    ( \[VCMeta a g VCObjectHash]
objs VCObjectHash
hsh -> do
        meta :: VCMeta a g VCObject
meta@VCMeta {VCObject
obj :: VCObject
obj :: forall author group o. VCMeta author group o -> o
obj, VCObjectVisibility
visibility :: forall author group o. VCMeta author group o -> VCObjectVisibility
visibility :: VCObjectVisibility
visibility, g
group :: forall author group o. VCMeta author group o -> group
group :: g
group} <- forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
fetchVCObject VCObjectHash
hsh
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case VCObject
obj of
          VCFunction Expr (Pinned VCObjectHash) ()
_ TCScheme
_ ->
            if VCObjectVisibility
visibility forall a. Eq a => a -> a -> Bool
== VCObjectVisibility
VCObjectPublic Bool -> Bool -> Bool
|| g
group forall a. Ord a => a -> Set a -> Bool
`Set.member` Set g
grps
              then (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const VCObjectHash
hsh) VCMeta a g VCObject
meta) forall a. a -> [a] -> [a]
: [VCMeta a g VCObjectHash]
objs
              else [VCMeta a g VCObjectHash]
objs
          VCObject
_ -> [VCMeta a g VCObjectHash]
objs
    )
    []
    [VCObjectHash]
heads