mirror of https://github.com/voidlizard/hbs2
282 lines
7.7 KiB
Haskell
282 lines
7.7 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2Git.Export where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Clock
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.OrDie
|
|
import HBS2.System.Logger.Simple
|
|
import HBS2.Merkle
|
|
import HBS2.Net.Proto.Definition()
|
|
import HBS2.Base58
|
|
|
|
import HBS2.Git.Local
|
|
import HBS2.Git.Local.CLI
|
|
|
|
import HBS2Git.App
|
|
import HBS2Git.State
|
|
import HBS2Git.Update
|
|
import HBS2Git.Config
|
|
|
|
import Data.Functor
|
|
import Data.List (sortBy)
|
|
import Control.Applicative
|
|
import Control.Monad.Reader
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS
|
|
import Data.Cache as Cache
|
|
import Data.Foldable (for_)
|
|
import Data.HashMap.Strict qualified as HashMap
|
|
import Data.HashSet qualified as HashSet
|
|
import Data.Maybe
|
|
import Data.Set qualified as Set
|
|
import Data.Set (Set)
|
|
import Lens.Micro.Platform
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.Async
|
|
import Control.Monad.Catch
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
import System.Directory
|
|
import System.FilePath
|
|
import Prettyprinter.Render.Terminal
|
|
|
|
data HashCache =
|
|
HashCache
|
|
{ hCache :: Cache GitHash (Set GitHash)
|
|
, hDb :: DBEnv
|
|
}
|
|
|
|
instance Hashable GitHash => HasCache HashCache GitHash (Set GitHash) IO where
|
|
cacheInsert (HashCache cache _) = Cache.insert cache
|
|
|
|
cacheLookup (HashCache cache db) k = do
|
|
refs <- withDB db (stateGetDeps k)
|
|
case refs of
|
|
[] -> Cache.lookup' cache k
|
|
xs -> pure $ Just $ Set.fromList xs
|
|
|
|
newHashCache :: MonadIO m => DBEnv -> m HashCache
|
|
newHashCache db = do
|
|
ca <- liftIO $ Cache.newCache Nothing
|
|
pure $ HashCache ca db
|
|
|
|
|
|
export :: forall m . ( MonadIO m
|
|
, MonadCatch m
|
|
, HasCatAPI m
|
|
, HasConf m
|
|
, HasRefCredentials m
|
|
, HasProgress m
|
|
) => RepoRef -> RepoHead -> m (HashRef, HashRef)
|
|
export h repoHead = do
|
|
|
|
let refs = HashMap.toList (view repoHeads repoHead)
|
|
|
|
let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead
|
|
|
|
dbPath <- makeDbPath h
|
|
|
|
trace $ "dbPath" <+> pretty dbPath
|
|
|
|
db <- dbEnv dbPath
|
|
|
|
sp <- withDB db savepointNew
|
|
|
|
withDB db $ savepointBegin sp
|
|
|
|
rr <- try $ do
|
|
|
|
skip <- withDB db stateGetExported <&> HashSet.fromList
|
|
|
|
-- TODO: process-only-commits-to-make-first-run-faster
|
|
ooo <- gitListAllObjects <&> filter (not . (`HashSet.member` skip))
|
|
|
|
cached0 <- withDB db stateGetAllDeps
|
|
let cached = HashMap.fromListWith (<>) [ (k, [v]) | (k,v) <- cached0 ]
|
|
let lookup h = pure $ HashMap.lookup h cached & fromMaybe mempty
|
|
|
|
monDep <- newProgressMonitor "calculate dependencies" (length ooo)
|
|
|
|
allDeps <- gitGetAllDependencies 4 ooo lookup (const $ updateProgress monDep 1)
|
|
|
|
let sz = length allDeps
|
|
mon1 <- newProgressMonitor "storing dependencies" sz
|
|
|
|
withDB db $ transactional do
|
|
for_ allDeps $ \(obj,dep) -> do
|
|
updateProgress mon1 1
|
|
stateAddDep dep obj
|
|
|
|
deps <- withDB db $ do
|
|
x <- forM refs $ stateGetDepsRec . snd
|
|
pure $ mconcat x
|
|
|
|
withDB db $ transactional do -- to speedup inserts
|
|
|
|
let metaApp = "application:" <+> "hbs2-git" <> line
|
|
|
|
let metaHead = fromString $ show
|
|
$ metaApp <> "type:" <+> "head" <> line
|
|
|
|
-- let gha = gitHashObject (GitObject Blob repoHead)
|
|
hh <- lift $ storeObject metaHead repoHeadStr `orDie` "cant save repo head"
|
|
|
|
mon3 <- newProgressMonitor "export objects from repo" (length deps)
|
|
|
|
for_ deps $ \d -> do
|
|
here <- stateGetHash d <&> isJust
|
|
-- FIXME: asap-check-if-objects-is-in-hbs2
|
|
unless here do
|
|
lbs <- gitReadObject Nothing d
|
|
|
|
-- TODO: why-not-default-blob
|
|
-- anything is blob
|
|
tp <- gitGetObjectType d <&> fromMaybe Blob --
|
|
|
|
let metaO = fromString $ show
|
|
$ metaApp
|
|
<> "type:" <+> pretty tp <+> pretty d
|
|
<> line
|
|
|
|
hr' <- lift $ storeObject metaO lbs
|
|
|
|
maybe1 hr' (pure ()) $ \hr -> do
|
|
statePutHash tp d hr
|
|
|
|
updateProgress mon3 1
|
|
|
|
hashes <- (hh : ) <$> stateGetAllHashes
|
|
|
|
let pt = toPTree (MaxSize 512) (MaxNum 512) hashes -- FIXME: settings
|
|
|
|
tobj <- liftIO newTQueueIO
|
|
-- FIXME: progress-indicator
|
|
root <- makeMerkle 0 pt $ \(ha,_,bss) -> do
|
|
liftIO $ atomically $ writeTQueue tobj (ha,bss)
|
|
|
|
objs <- liftIO $ atomically $ flushTQueue tobj
|
|
|
|
mon2 <- newProgressMonitor "store objects" (length objs)
|
|
|
|
for_ objs $ \(ha,bss) -> do
|
|
updateProgress mon2 1
|
|
here <- lift $ getBlockSize (HashRef ha) <&> isJust
|
|
unless here do
|
|
void $ lift $ storeObject (fromString (show metaApp)) bss
|
|
|
|
trace "generate update transaction"
|
|
|
|
trace $ "objects:" <+> pretty (length hashes)
|
|
|
|
seqno <- stateGetSequence <&> succ
|
|
-- FIXME: same-transaction-different-seqno
|
|
|
|
postRefUpdate h seqno (HashRef root)
|
|
|
|
let noRef = do
|
|
pause @'Seconds 20
|
|
shutUp
|
|
die $ show $ pretty "No reference appeared for" <+> pretty h
|
|
|
|
wmon <- newProgressMonitor "waiting for ref" 20
|
|
void $ liftIO $ race noRef $ do
|
|
runApp NoLog do
|
|
fix \next -> do
|
|
v <- readRefHttp h
|
|
updateProgress wmon 1
|
|
case v of
|
|
Nothing -> pause @'Seconds 1 >> next
|
|
Just{} -> pure ()
|
|
|
|
|
|
withDB db $ transactional $ mapM_ statePutExported ooo
|
|
|
|
pure (HashRef root, hh)
|
|
|
|
case rr of
|
|
Left ( e :: SomeException ) -> do
|
|
withDB db (savepointRollback sp)
|
|
err $ viaShow e
|
|
shutUp
|
|
die "aborted"
|
|
|
|
Right r -> do
|
|
withDB db (savepointRelease sp)
|
|
pure r
|
|
|
|
|
|
runExport :: forall m . (MonadIO m, MonadCatch m, HasProgress (App m))
|
|
=> Maybe FilePath -> RepoRef -> App m ()
|
|
runExport fp h = do
|
|
|
|
|
|
liftIO $ putDoc $
|
|
line
|
|
<> green "Exporting to reflog" <+> pretty (AsBase58 h)
|
|
<> section
|
|
<> "it may take some time on the first run"
|
|
<> section
|
|
|
|
git <- asks (view appGitDir)
|
|
|
|
trace $ "git directory is" <+> pretty git
|
|
|
|
loadCredentials (maybeToList fp)
|
|
|
|
-- FIXME: wtf-runExport
|
|
branchesGr <- cfgValue @ConfBranch <&> Set.map normalizeRef
|
|
|
|
headBranch <- gitGetBranchHEAD `orDie` "undefined HEAD for repo"
|
|
|
|
refs <- gitListLocalBranches
|
|
<&> filter (\x -> Set.null branchesGr || Set.member (fst x) branchesGr)
|
|
|
|
trace $ "REFS" <+> pretty refs
|
|
|
|
fullHead <- gitHeadFullName headBranch
|
|
|
|
debug $ "HEAD" <+> pretty fullHead
|
|
|
|
let repoHead = RepoHead (Just fullHead)
|
|
(HashMap.fromList refs)
|
|
|
|
trace $ "NEW REPO HEAD" <+> pretty (AsGitRefsFile repoHead)
|
|
|
|
(root, hhh) <- export h repoHead
|
|
|
|
updateLocalState h
|
|
|
|
shutUp
|
|
|
|
cwd <- liftIO getCurrentDirectory
|
|
cfgPath <- configPath cwd
|
|
let krf = fromMaybe "keyring-file" fp & takeFileName
|
|
|
|
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putDoc $
|
|
"exported" <+> pretty hhh
|
|
<> section
|
|
<> green "Repository config:" <+> pretty (cfgPath </> "config")
|
|
<> section
|
|
<> "Put the keyring file" <+> yellow (pretty krf) <+> "into a safe place," <> line
|
|
<> "like encrypted directory or volume."
|
|
<> section
|
|
<> "You will need this keyring to push into the repository."
|
|
<> section
|
|
<> green "Add keyring into the repo's config:"
|
|
<> section
|
|
<> "keyring" <+> pretty [qc|"/my/safe/place/{krf}"|]
|
|
<> section
|
|
<> green "Add git remote:"
|
|
<> section
|
|
<> pretty [qc|git remote add remotename hbs2://{pretty h}|]
|
|
<> section
|
|
<> green "Work with git as usual:"
|
|
<> section
|
|
<> "git pull remotename" <> line
|
|
<> "(or git fetch remotename && git reset --hard remotename/branch)" <> line
|
|
<> "git push remotename" <> line
|
|
<> line
|
|
|
|
|