mirror of https://github.com/voidlizard/hbs2
338 lines
12 KiB
Haskell
338 lines
12 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
||
module HBS2Git.Export where
|
||
|
||
import HBS2.Prelude.Plated
|
||
import HBS2.Data.Types.Refs
|
||
import HBS2.OrDie
|
||
import HBS2.System.Logger.Simple
|
||
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.Config
|
||
import HBS2Git.GitRepoLog
|
||
|
||
import Control.Applicative
|
||
import Control.Monad.Catch
|
||
import Control.Monad.Reader
|
||
import UnliftIO.Async
|
||
import Control.Concurrent.STM
|
||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||
import Data.Foldable (for_)
|
||
import Data.Functor
|
||
import Data.HashMap.Strict qualified as HashMap
|
||
import Data.HashSet qualified as HashSet
|
||
import Data.HashSet (HashSet)
|
||
import Data.Maybe
|
||
import Data.Set qualified as Set
|
||
import Data.Map qualified as Map
|
||
import Data.List qualified as List
|
||
import Lens.Micro.Platform
|
||
import Prettyprinter.Render.Terminal
|
||
import System.Directory
|
||
import System.FilePath
|
||
import Text.InterpolatedString.Perl6 (qc)
|
||
import UnliftIO.IO
|
||
import System.IO hiding (hClose,hPrint)
|
||
import System.IO.Temp
|
||
import Control.Monad.Trans.Resource
|
||
|
||
class ExportRepoOps a where
|
||
|
||
instance ExportRepoOps ()
|
||
|
||
exportRefDeleted :: forall o m . ( MonadIO m
|
||
, MonadCatch m
|
||
-- , MonadMask m
|
||
, MonadUnliftIO m
|
||
, HasCatAPI m
|
||
, HasConf m
|
||
, HasRefCredentials m
|
||
, HasProgress m
|
||
, ExportRepoOps o
|
||
)
|
||
=> o
|
||
-> RepoRef
|
||
-> GitRef
|
||
-> m HashRef
|
||
exportRefDeleted _ repo ref = do
|
||
trace $ "exportRefDeleted" <+> pretty repo <+> pretty ref
|
||
|
||
dbPath <- makeDbPath repo
|
||
db <- dbEnv dbPath
|
||
|
||
-- это "ненормальный" лог, т.е удаление ссылки в текущем контексте
|
||
-- мы удаляем ссылку "там", то есть нам нужно "то" значение ссылки
|
||
-- удалить её локально мы можем и так, просто гитом.
|
||
-- NOTE: empty-log-post
|
||
-- мы тут постим пустой лог (не содержащий коммитов)
|
||
-- нам нужно будет найти его позицию относитеьлно прочих логов.
|
||
-- его контекст = текущее значение ссылки, которое мы удаляем
|
||
-- но вот если мы удаляем уже удаленную ссылку, то для ссылки 00..0
|
||
-- будет ошибка где-то.
|
||
|
||
vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd
|
||
|
||
let (ctxHead, ctxBs) = makeContextEntry vals
|
||
|
||
trace $ "DELETING REF CONTEXT" <+> pretty vals
|
||
|
||
let repoHead = RepoHead Nothing (HashMap.fromList [(ref,"0000000000000000000000000000000000000000")])
|
||
let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead
|
||
let ha = gitHashObject (GitObject Blob repoHeadStr)
|
||
let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr )
|
||
|
||
let content = gitRepoLogMakeEntry ctxHead ctxBs
|
||
<> gitRepoLogMakeEntry headEntry repoHeadStr
|
||
|
||
-- FIXME: remove-code-dup
|
||
let meta = fromString $ show
|
||
$ "hbs2-git" <> line
|
||
<> "type:" <+> "hbs2-git-push-log"
|
||
<> line
|
||
|
||
logMerkle <- storeObject meta content `orDie` [qc|Can't store push log|]
|
||
postRefUpdate repo 0 logMerkle
|
||
pure logMerkle
|
||
|
||
makeContextEntry :: [GitHash] -> (GitLogEntry, LBS.ByteString)
|
||
makeContextEntry hashes = (entryHead, payload)
|
||
where
|
||
ha = Nothing
|
||
payload = GitLogContextCommits (HashSet.fromList hashes) & serialise
|
||
entryHead = GitLogEntry GitLogContext ha undefined
|
||
|
||
-- | Exports only one ref to the repo.
|
||
-- Corresponds to a single ```git push``` operation
|
||
exportRefOnly :: forall o m . ( MonadIO m
|
||
, MonadCatch m
|
||
-- , MonadMask m
|
||
, MonadUnliftIO m
|
||
, HasCatAPI m
|
||
, HasConf m
|
||
, HasRefCredentials m
|
||
, HasProgress m
|
||
, ExportRepoOps o
|
||
)
|
||
=> o
|
||
-> RepoRef
|
||
-> Maybe GitRef
|
||
-> GitRef
|
||
-> GitHash
|
||
-> m HashRef
|
||
|
||
exportRefOnly _ remote rfrom ref val = do
|
||
|
||
let repoHead = RepoHead Nothing (HashMap.fromList [(ref,val)])
|
||
|
||
let repoHeadStr = (LBS.pack . show . pretty . AsGitRefsFile) repoHead
|
||
|
||
dbPath <- makeDbPath remote
|
||
db <- dbEnv dbPath
|
||
|
||
trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val
|
||
|
||
-- 1. get max ref value for known REMOTE branch
|
||
-- 2. if unkwnown - get max branch ref value for known LOCAL branch (known from the state)
|
||
-- 3. if unkwnown - then Nothing
|
||
-- therefore, we export only the delta for the objects for push between known state and current
|
||
-- git repot state
|
||
-- if it's a new branch push without any objects commited -- then empty log
|
||
-- only with HEAD section should be created
|
||
lastKnownRev <- withDB db do
|
||
rThat <- stateGetActualRefValue ref
|
||
rThis <- maybe1 rfrom (pure Nothing) stateGetActualRefValue
|
||
pure $ rThat <|> rThis
|
||
|
||
trace $ "LAST_KNOWN_REV" <+> braces (pretty rfrom) <+> braces (pretty ref) <+> braces (pretty lastKnownRev)
|
||
|
||
entries <- gitRevList lastKnownRev val
|
||
|
||
-- NOTE: just-for-test-new-non-empty-push-to-another-branch-112
|
||
|
||
-- FIXME: may-blow-on-huge-repo-export
|
||
types <- gitGetObjectTypeMany entries <&> Map.fromList
|
||
|
||
let lookupType t = Map.lookup t types
|
||
let justOrDie msg x = pure x `orDie` msg
|
||
|
||
trace $ "ENTRIES:" <+> pretty (length entries)
|
||
|
||
trace "MAKING OBJECTS LOG"
|
||
|
||
let fname = [qc|{pretty val}.data|]
|
||
|
||
runResourceT $ do
|
||
|
||
written <- liftIO $ newTVarIO (HashSet.empty :: HashSet GitHash)
|
||
|
||
let myTempDir = "hbs-git"
|
||
temp <- liftIO getCanonicalTemporaryDirectory
|
||
(_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
|
||
|
||
let fpath = dir </> fname
|
||
fh <- liftIO $ openBinaryFile fpath AppendMode
|
||
|
||
expMon <- newProgressMonitor "export objects" (length entries)
|
||
|
||
enq <- liftIO newTQueueIO
|
||
|
||
-- FIXME: export-wtf?
|
||
|
||
aread <- async $ do
|
||
for_ entries $ \d -> do
|
||
here <- liftIO $ readTVarIO written <&> HashSet.member d
|
||
inState <- withDB db (stateIsLogObjectExists d)
|
||
updateProgress expMon 1
|
||
unless (here || inState) do
|
||
tp <- lookupType d & justOrDie [qc|no object type for {pretty d}|]
|
||
o <- gitReadObject (Just tp) d
|
||
let entry = GitLogEntry ( gitLogEntryTypeOf tp ) (Just d) ( fromIntegral $ LBS.length o )
|
||
liftIO $ atomically $ writeTQueue enq (Just (d,tp,entry,o))
|
||
|
||
liftIO $ atomically $ writeTQueue enq Nothing
|
||
|
||
fix \next -> do
|
||
mbEntry <- liftIO $ atomically $ readTQueue enq
|
||
case mbEntry of
|
||
Nothing -> pure ()
|
||
Just (d,tp,entry,o) -> do
|
||
gitRepoLogWriteEntry fh entry o
|
||
liftIO $ atomically $ modifyTVar written (HashSet.insert d)
|
||
trace $ "writing" <+> pretty tp <+> pretty d
|
||
-- TODO: here-split-log-to-parts
|
||
next
|
||
|
||
mapM_ wait [aread]
|
||
|
||
-- FIXME: problem-log-is-not-assotiated-with-commit
|
||
-- Если так получилось, что в журнале подъехала только ссылка,
|
||
-- и больше нет никакой информации -- мы не можем определить
|
||
-- глубину(высоту?) этой ссылки, и, соответственно, вычислить
|
||
-- её depth в стейте.
|
||
-- Решение: в этом (или иных) случаях добавлять информацию о контексте,
|
||
-- например, состояние других известных ссылок в моменте. Список ссылок
|
||
-- берём из state, полагая, что раз ссылка в стейте, значит, она является
|
||
-- важной. Имея эту информацию, мы можем хоть как-то вычислять depth
|
||
-- этого лога. Похоже на векторные часы, кстати.
|
||
|
||
-- это "нормальный" лог. даже если хвост его приедет пустым (не будет коммитов)
|
||
-- тут мы запомним, что его контекст = коммит, на который он устанавливает ссылку
|
||
-- и этот коммит должен быть в секциях лога, которые приехали перед ним.
|
||
-- следствие: у предыдущего лога будет такая же глубина, как и у этого.
|
||
|
||
vals <- withDB db $ stateGetActualRefs <&> List.nub . fmap snd
|
||
let (e, bs) = makeContextEntry (val:vals)
|
||
trace $ "writing context entry" <+> pretty [val]
|
||
gitRepoLogWriteEntry fh e bs
|
||
|
||
let ha = gitHashObject (GitObject Blob repoHeadStr)
|
||
let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr )
|
||
gitRepoLogWriteEntry fh headEntry repoHeadStr
|
||
|
||
-- TODO: find-prev-push-log-and-make-ref
|
||
gitRepoLogWriteHead fh (GitLogHeadEntry Nothing)
|
||
|
||
hClose fh
|
||
|
||
trace "STORING PUSH LOG"
|
||
|
||
let meta = fromString $ show
|
||
$ "hbs2-git" <> line
|
||
<> "type:" <+> "hbs2-git-push-log"
|
||
<> line
|
||
|
||
content <- liftIO $ LBS.readFile fpath
|
||
logMerkle <- lift $ storeObject meta content `orDie` [qc|Can't store push log|]
|
||
|
||
trace $ "PUSH LOG HASH: " <+> pretty logMerkle
|
||
trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle
|
||
|
||
-- FIXME: calculate-seqno-as-topsort-order
|
||
lift $ postRefUpdate remote 0 logMerkle
|
||
|
||
pure logMerkle
|
||
|
||
runExport :: forall m . (MonadIO m, MonadUnliftIO m, MonadCatch m, HasProgress (App m))
|
||
=> Maybe FilePath -> RepoRef -> App m ()
|
||
runExport fp repo = do
|
||
|
||
|
||
liftIO $ putDoc $
|
||
line
|
||
<> green "Exporting to reflog" <+> pretty (AsBase58 repo)
|
||
<> 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)
|
||
|
||
val <- gitGetHash fullHead `orDie` [qc|Can't resolve ref {pretty fullHead}|]
|
||
|
||
-- _ <- exportRefOnly () remote br gh
|
||
hhh <- exportRefOnly () repo Nothing fullHead val
|
||
|
||
-- NOTE: ???
|
||
-- traceTime "importRefLogNew (export)" $ importRefLogNew False repo
|
||
|
||
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 repo}|]
|
||
<> 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
|
||
|
||
|