mirror of https://github.com/voidlizard/hbs2
new hbs2-git
This commit is contained in:
Dmitry Zuikov
parent
da42a1dc69
commit
29e7a1e2fd
2
Makefile
2
Makefile
|
|
@ -15,6 +15,8 @@ BINS := \
|
||||||
hbs2-git-reposync \
|
hbs2-git-reposync \
|
||||||
git-remote-hbs2 \
|
git-remote-hbs2 \
|
||||||
git-hbs2 \
|
git-hbs2 \
|
||||||
|
git-remote-hbs21 \
|
||||||
|
git-hbs21 \
|
||||||
|
|
||||||
ifeq ($(origin .RECIPEPREFIX), undefined)
|
ifeq ($(origin .RECIPEPREFIX), undefined)
|
||||||
$(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)
|
$(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)
|
||||||
|
|
|
||||||
|
|
@ -37,6 +37,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
||||||
"hbs2-qblf"
|
"hbs2-qblf"
|
||||||
"hbs2-keyman"
|
"hbs2-keyman"
|
||||||
"hbs2-share"
|
"hbs2-share"
|
||||||
|
"hbs21-git"
|
||||||
];
|
];
|
||||||
in
|
in
|
||||||
haskell-flake-utils.lib.simpleCabalProject2flake {
|
haskell-flake-utils.lib.simpleCabalProject2flake {
|
||||||
|
|
@ -60,6 +61,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
||||||
"hbs2-keyman" = "./hbs2-keyman";
|
"hbs2-keyman" = "./hbs2-keyman";
|
||||||
"hbs2-share" = "./hbs2-share";
|
"hbs2-share" = "./hbs2-share";
|
||||||
"hbs2-git" = "./hbs2-git";
|
"hbs2-git" = "./hbs2-git";
|
||||||
|
"hbs21-git" = "./hbs21-git";
|
||||||
"hbs2-git-reposync" = "./hbs2-git-reposync";
|
"hbs2-git-reposync" = "./hbs2-git-reposync";
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,209 @@
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude hiding (info)
|
||||||
|
import HBS2.Git.Client.App
|
||||||
|
import HBS2.Git.Client.Export
|
||||||
|
import HBS2.Git.Client.Import
|
||||||
|
import HBS2.Git.Client.State
|
||||||
|
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
import HBS2.Git.Local.CLI qualified as Git
|
||||||
|
import HBS2.Git.Data.Tx qualified as TX
|
||||||
|
import HBS2.Git.Data.Tx (RepoHead(..))
|
||||||
|
import HBS2.Git.Data.GK
|
||||||
|
|
||||||
|
import HBS2.Storage.Operations.ByteString
|
||||||
|
|
||||||
|
import Options.Applicative as O
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
|
||||||
|
import System.Exit
|
||||||
|
|
||||||
|
globalOptions :: Parser [GitOption]
|
||||||
|
globalOptions = do
|
||||||
|
|
||||||
|
t <- flag [] [GitTrace]
|
||||||
|
( long "trace" <> short 't' <> help "allow trace"
|
||||||
|
)
|
||||||
|
|
||||||
|
d <- flag [] [GitDebug]
|
||||||
|
( long "debug" <> short 'd' <> help "allow debug"
|
||||||
|
)
|
||||||
|
|
||||||
|
pure (t <> d)
|
||||||
|
|
||||||
|
commands :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
commands =
|
||||||
|
hsubparser ( command "export" (info pExport (progDesc "export repo to hbs2-git"))
|
||||||
|
<> command "import" (info pImport (progDesc "import repo from reflog"))
|
||||||
|
<> command "key" (info pKey (progDesc "key management"))
|
||||||
|
<> command "tools" (info pTools (progDesc "misc tools"))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
pRefLogId :: ReadM RefLogId
|
||||||
|
pRefLogId = maybeReader (fromStringMay @RefLogId)
|
||||||
|
|
||||||
|
|
||||||
|
pHashRef :: ReadM HashRef
|
||||||
|
pHashRef = maybeReader (fromStringMay @HashRef)
|
||||||
|
|
||||||
|
pInit :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pInit = do
|
||||||
|
pure runDefault
|
||||||
|
|
||||||
|
|
||||||
|
pExport :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pExport = do
|
||||||
|
|
||||||
|
puk <- argument pRefLogId (metavar "REFLOG-KEY")
|
||||||
|
|
||||||
|
et <- flag ExportInc ExportNew
|
||||||
|
( long "new" <> help "new is usable to export to a new empty reflog"
|
||||||
|
)
|
||||||
|
|
||||||
|
enc <- flag' ExportPublic (long "public" <> help "create unencrypted reflog")
|
||||||
|
<|>
|
||||||
|
( ExportPrivate <$>
|
||||||
|
strOption (long "encrypted" <> help "create encrypted reflog"
|
||||||
|
<> metavar "GROUP-KEY-FILE")
|
||||||
|
)
|
||||||
|
|
||||||
|
pure do
|
||||||
|
git <- Git.findGitDir >>= orThrowUser "not a git dir"
|
||||||
|
notice (green "git dir" <+> pretty git <+> pretty (AsBase58 puk))
|
||||||
|
|
||||||
|
env <- ask
|
||||||
|
|
||||||
|
withGitEnv ( env & set gitApplyHeads False & set gitExportType et & set gitExportEnc enc) do
|
||||||
|
|
||||||
|
notice $ red (viaShow et)
|
||||||
|
unless (et == ExportNew) do
|
||||||
|
importRepoWait puk
|
||||||
|
|
||||||
|
export puk mempty
|
||||||
|
|
||||||
|
pImport :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pImport = do
|
||||||
|
puk <- argument pRefLogId (metavar "REFLOG-KEY")
|
||||||
|
|
||||||
|
pure do
|
||||||
|
git <- Git.findGitDir >>= orThrowUser "not a git dir"
|
||||||
|
importRepoWait puk
|
||||||
|
|
||||||
|
pTools :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pTools = hsubparser ( command "dump-pack" (info pDumpPack (progDesc "dump hbs2 git pack"))
|
||||||
|
<> command "show-ref" (info pShowRef (progDesc "show current references"))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
data DumpOpt = DumpInfoOnly | DumpObjects | DumpPack
|
||||||
|
|
||||||
|
pDumpPack :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pDumpPack = do
|
||||||
|
what <- dumpInfoOnly <|> dumpObjects <|> dumpPack
|
||||||
|
pure do
|
||||||
|
co <- liftIO LBS.getContents
|
||||||
|
|
||||||
|
(idSize,idVer,sidx,pack) <- TX.unpackPackMay co
|
||||||
|
& orThrowUser "can't unpack the bundle"
|
||||||
|
|
||||||
|
case what of
|
||||||
|
DumpInfoOnly -> do
|
||||||
|
liftIO $ print $ pretty "version:" <+> pretty idVer <> line
|
||||||
|
<> "index size:" <+> pretty idSize <> line
|
||||||
|
<> "objects:" <+> pretty (length sidx)
|
||||||
|
DumpObjects -> do
|
||||||
|
liftIO $ print $ vcat (fmap pretty sidx)
|
||||||
|
|
||||||
|
DumpPack -> do
|
||||||
|
liftIO $ LBS.putStr pack
|
||||||
|
|
||||||
|
where
|
||||||
|
dumpInfoOnly = flag DumpInfoOnly DumpInfoOnly
|
||||||
|
( long "info-only" )
|
||||||
|
|
||||||
|
dumpObjects = flag DumpObjects DumpObjects
|
||||||
|
( long "objects" )
|
||||||
|
|
||||||
|
dumpPack = flag DumpPack DumpPack
|
||||||
|
( long "pack" )
|
||||||
|
|
||||||
|
|
||||||
|
pShowRef :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pShowRef = do
|
||||||
|
pure do
|
||||||
|
sto <- asks _storage
|
||||||
|
void $ runMaybeT do
|
||||||
|
|
||||||
|
tx <- withState do
|
||||||
|
selectMaxAppliedTx >>= lift . toMPlus <&> fst
|
||||||
|
|
||||||
|
rh <- TX.readRepoHeadFromTx sto tx >>= toMPlus
|
||||||
|
|
||||||
|
liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh))
|
||||||
|
|
||||||
|
|
||||||
|
pKey :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pKey = hsubparser ( command "show" (info pKeyShow (progDesc "show current key"))
|
||||||
|
<> command "update" (info pKeyUpdate (progDesc "update current key"))
|
||||||
|
)
|
||||||
|
<|> pKeyShow
|
||||||
|
|
||||||
|
pKeyShow :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pKeyShow = do
|
||||||
|
full <- flag False True (long "full" <> help "show full key info")
|
||||||
|
pure do
|
||||||
|
sto <- asks _storage
|
||||||
|
void $ runMaybeT do
|
||||||
|
|
||||||
|
tx <- withState do
|
||||||
|
selectMaxAppliedTx >>= lift . toMPlus <&> fst
|
||||||
|
|
||||||
|
rh <- TX.readRepoHeadFromTx sto tx
|
||||||
|
>>= toMPlus
|
||||||
|
|
||||||
|
gkh <- toMPlus (_repoHeadGK0 rh)
|
||||||
|
|
||||||
|
if not full then do
|
||||||
|
liftIO $ print $ pretty gkh
|
||||||
|
else do
|
||||||
|
gk <- runExceptT (readGK0 sto gkh) >>= toMPlus
|
||||||
|
liftIO $ print $ ";; group key" <+> pretty gkh <> line <> line <> pretty gk
|
||||||
|
|
||||||
|
pKeyUpdate :: GitPerks m => Parser (GitCLI m ())
|
||||||
|
pKeyUpdate = do
|
||||||
|
rlog <- argument pRefLogId (metavar "REFLOG-KEY")
|
||||||
|
fn <- strArgument (metavar "GROUP-KEY-FILE")
|
||||||
|
pure do
|
||||||
|
gk <- loadGK0FromFile fn
|
||||||
|
`orDie` "can not load group key or invalid format"
|
||||||
|
|
||||||
|
sto <- asks _storage
|
||||||
|
|
||||||
|
gh <- writeAsMerkle sto (serialise gk) <&> HashRef
|
||||||
|
|
||||||
|
added <- withState $ runMaybeT do
|
||||||
|
(tx,_) <- lift selectMaxAppliedTx >>= toMPlus
|
||||||
|
lift do
|
||||||
|
insertNewGK0 rlog tx gh
|
||||||
|
commitAll
|
||||||
|
pure gh
|
||||||
|
|
||||||
|
case added of
|
||||||
|
Nothing -> liftIO $ putStrLn "not added" >> exitFailure
|
||||||
|
Just x -> liftIO $ print $ pretty x
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
(o, action) <- customExecParser (prefs showHelpOnError) $
|
||||||
|
O.info (liftA2 (,) globalOptions commands <**> helper)
|
||||||
|
( fullDesc
|
||||||
|
<> header "hbs2-git"
|
||||||
|
<> progDesc "hbs2-git"
|
||||||
|
)
|
||||||
|
|
||||||
|
runGitCLI o action
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,204 @@
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Prelude hiding (getLine)
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
import HBS2.Git.Client.App
|
||||||
|
import HBS2.Git.Client.Import
|
||||||
|
import HBS2.Git.Client.Export
|
||||||
|
import HBS2.Git.Client.State
|
||||||
|
import HBS2.Git.Client.Progress
|
||||||
|
import HBS2.Git.Client.Config
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
import HBS2.Git.Data.Tx qualified as TX
|
||||||
|
import HBS2.Git.Data.Tx (RepoHead(..))
|
||||||
|
|
||||||
|
import HBS2.System.Dir
|
||||||
|
|
||||||
|
import Control.Concurrent.STM qualified as STM
|
||||||
|
import System.Posix.Signals
|
||||||
|
import System.Environment
|
||||||
|
import System.IO (hPutStrLn)
|
||||||
|
import System.IO qualified as IO
|
||||||
|
import System.Exit qualified as Exit
|
||||||
|
|
||||||
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||||
|
import Data.Attoparsec.ByteString.Char8 hiding (try)
|
||||||
|
import Data.Attoparsec.ByteString.Char8 qualified as Atto
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Data.List qualified as L
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
import System.Exit hiding (die)
|
||||||
|
|
||||||
|
{- HLINT ignore "Use isEOF" -}
|
||||||
|
{- HLINT ignore "Use putStrLn" -}
|
||||||
|
|
||||||
|
done :: MonadIO m => m Bool
|
||||||
|
done = hIsEOF stdin
|
||||||
|
|
||||||
|
getLine :: MonadIO m => m String
|
||||||
|
getLine = liftIO IO.getLine
|
||||||
|
|
||||||
|
sendLine :: MonadIO m => String -> m ()
|
||||||
|
sendLine = liftIO . IO.putStrLn
|
||||||
|
|
||||||
|
die :: (MonadIO m, Pretty a) => a -> m b
|
||||||
|
die s = liftIO $ Exit.die (show $ pretty s)
|
||||||
|
|
||||||
|
parseURL :: String -> Maybe RefLogId
|
||||||
|
parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
|
||||||
|
where
|
||||||
|
p = do
|
||||||
|
void $ string "hbs21://" <|> string "hbs2://"
|
||||||
|
|
||||||
|
Atto.takeWhile1 (`elem` getAlphabet)
|
||||||
|
<&> BS8.unpack
|
||||||
|
<&> fromStringMay @RefLogId
|
||||||
|
>>= maybe (fail "invalid reflog key") pure
|
||||||
|
|
||||||
|
parsePush :: String -> Maybe (Maybe GitRef, GitRef)
|
||||||
|
parsePush s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
|
||||||
|
where
|
||||||
|
gitref = fromString @GitRef . BS8.unpack
|
||||||
|
p = do
|
||||||
|
a <- optional (Atto.takeWhile1 (/= ':')) <&> fmap gitref
|
||||||
|
char ':'
|
||||||
|
b <- Atto.takeWhile1 (const True) <&> gitref
|
||||||
|
pure (a,b)
|
||||||
|
|
||||||
|
data S =
|
||||||
|
Plain
|
||||||
|
| Push
|
||||||
|
deriving stock (Eq,Ord,Show,Enum)
|
||||||
|
|
||||||
|
|
||||||
|
{- HLINT ignore "Functor law" -}
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
hSetBuffering stdin LineBuffering
|
||||||
|
hSetBuffering stdout LineBuffering
|
||||||
|
|
||||||
|
void $ installHandler sigPIPE Ignore Nothing
|
||||||
|
|
||||||
|
args <- getArgs
|
||||||
|
|
||||||
|
(remote, puk) <- case args of
|
||||||
|
[s, u] ->
|
||||||
|
(s,) <$> pure (parseURL u)
|
||||||
|
`orDie` show ("invalid reflog" <+> pretty u)
|
||||||
|
|
||||||
|
_ -> die "bad args"
|
||||||
|
|
||||||
|
runGitCLI mempty $ do
|
||||||
|
|
||||||
|
env <- ask
|
||||||
|
|
||||||
|
flip runContT pure do
|
||||||
|
|
||||||
|
lift $ withGitEnv (env & set gitApplyHeads False) do
|
||||||
|
|
||||||
|
debug $ red "run" <+> pretty args
|
||||||
|
|
||||||
|
sto <- asks _storage
|
||||||
|
ip <- asks _progress
|
||||||
|
|
||||||
|
importRepoWait puk
|
||||||
|
`catch` (\(_ :: ImportRefLogNotFound) -> do
|
||||||
|
onProgress ip ImportAllDone
|
||||||
|
let url = headMay (catMaybes [ parseURL a | a <- args]) <&> AsBase58
|
||||||
|
pause @'Seconds 0.25
|
||||||
|
liftIO $ hFlush stderr
|
||||||
|
liftIO $ hPutDoc stderr $ ""
|
||||||
|
<> ul (yellow "Reflog" <+> pretty url <+> yellow "is not available yet.") <> line
|
||||||
|
<> "If you sure it's a new one -- make sure you've added the key to hbs2-keyman and then run"
|
||||||
|
<> line <> line
|
||||||
|
<> "hbs2-keyman update" <> line <> line
|
||||||
|
<> "git" <+> pretty hbs2Name <+> "export --new" <+> pretty url <> line <> line
|
||||||
|
<> "to init the reflog first." <> line
|
||||||
|
<> "Pushing to an existing reflog as a new one may cause unwanted data duplication." <> line
|
||||||
|
<> line
|
||||||
|
<> "Note: what ever pushed -- can not be unpushed" <> line
|
||||||
|
<> "If it's not a new reflog --- just wait until it became available"
|
||||||
|
liftIO exitFailure
|
||||||
|
)
|
||||||
|
|
||||||
|
void $ runExceptT do
|
||||||
|
|
||||||
|
tpush <- newTQueueIO -- @(GitRef, Maybe GitHash)
|
||||||
|
|
||||||
|
flip fix Plain $ \next s -> do
|
||||||
|
|
||||||
|
eof <- done
|
||||||
|
|
||||||
|
when eof $ pure ()
|
||||||
|
|
||||||
|
cmd <- ExceptT (try @_ @IOError (getLine <&> words))
|
||||||
|
|
||||||
|
debug $ "C:" <+> pretty cmd
|
||||||
|
|
||||||
|
case cmd of
|
||||||
|
|
||||||
|
[] | s == Plain -> do
|
||||||
|
onProgress ip (ImportSetQuiet True)
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
[] | s == Push -> do
|
||||||
|
refs <- atomically (STM.flushTQueue tpush)
|
||||||
|
<&> HM.toList . HM.fromList
|
||||||
|
|
||||||
|
importRepoWait puk
|
||||||
|
export puk refs
|
||||||
|
sendLine ""
|
||||||
|
next Plain
|
||||||
|
|
||||||
|
["capabilities"] -> do
|
||||||
|
debug $ "send capabilities"
|
||||||
|
sendLine "push"
|
||||||
|
sendLine "fetch"
|
||||||
|
sendLine ""
|
||||||
|
next Plain
|
||||||
|
|
||||||
|
("list" : _) -> do
|
||||||
|
|
||||||
|
|
||||||
|
r' <- runMaybeT $ withState do
|
||||||
|
tx <- selectMaxAppliedTx >>= lift . toMPlus <&> fst
|
||||||
|
|
||||||
|
rh <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
|
||||||
|
pure (_repoHeadRefs rh)
|
||||||
|
|
||||||
|
let r = fromMaybe mempty r'
|
||||||
|
|
||||||
|
forM_ (fmap (show . formatRef) r) sendLine
|
||||||
|
|
||||||
|
sendLine ""
|
||||||
|
|
||||||
|
next Plain
|
||||||
|
|
||||||
|
("push" : pargs : _ ) -> do
|
||||||
|
(fromRef, toRef) <- orThrowUser "can't parse push" (parsePush pargs)
|
||||||
|
|
||||||
|
r <- readProcess (setStderr closed $ shell [qc|git rev-parse {pretty $ fromRef}|])
|
||||||
|
<&> headDef "" . LBS8.words . view _2
|
||||||
|
<&> fromStringMay @GitHash . LBS8.unpack
|
||||||
|
|
||||||
|
let val = const r =<< fromRef
|
||||||
|
|
||||||
|
atomically $ writeTQueue tpush (toRef, val)
|
||||||
|
|
||||||
|
sendLine [qc|ok {pretty toRef}|]
|
||||||
|
next Push
|
||||||
|
|
||||||
|
_ -> next Plain
|
||||||
|
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
`finally` liftIO do
|
||||||
|
hPutStrLn stdout "" >> hFlush stdout
|
||||||
|
-- notice $ red "BYE"
|
||||||
|
hPutStrLn stderr ""
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,193 @@
|
||||||
|
module HBS2.Git.Client.App
|
||||||
|
( module HBS2.Git.Client.App
|
||||||
|
, module HBS2.Git.Client.App.Types
|
||||||
|
) where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude hiding (info)
|
||||||
|
import HBS2.Git.Client.App.Types
|
||||||
|
import HBS2.Git.Client.Config
|
||||||
|
import HBS2.Git.Client.Progress
|
||||||
|
import HBS2.Git.Client.State
|
||||||
|
|
||||||
|
import HBS2.Git.Data.Tx
|
||||||
|
|
||||||
|
import HBS2.Git.Local.CLI
|
||||||
|
|
||||||
|
import HBS2.System.Dir
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
import System.Environment
|
||||||
|
import System.IO (hPutStr)
|
||||||
|
import Data.Vector qualified as V
|
||||||
|
import Data.Vector ((!))
|
||||||
|
|
||||||
|
drawProgress :: MonadUnliftIO m => ProgressQ -> m ()
|
||||||
|
drawProgress (ProgressQ q) = do
|
||||||
|
|
||||||
|
let spin = V.fromList ["--","\\","|","/"]
|
||||||
|
let l = V.length spin
|
||||||
|
i <- newTVarIO 0
|
||||||
|
|
||||||
|
tl <- newTVarIO =<< getTimeCoarse
|
||||||
|
|
||||||
|
let updateSpinner = do
|
||||||
|
atomically $ modifyTVar i succ
|
||||||
|
|
||||||
|
let getSpinner = do
|
||||||
|
j <- readTVarIO i <&> (`mod` l)
|
||||||
|
pure $ spin ! j
|
||||||
|
|
||||||
|
let
|
||||||
|
limit :: MonadIO m => Timeout 'Seconds -> m () -> m ()
|
||||||
|
limit dt m = do
|
||||||
|
t0 <- readTVarIO tl
|
||||||
|
now <- getTimeCoarse
|
||||||
|
when (expired dt (now - t0)) do
|
||||||
|
atomically $ writeTVar tl now
|
||||||
|
m
|
||||||
|
|
||||||
|
let loop = do
|
||||||
|
flip fix False \next quiet -> do
|
||||||
|
|
||||||
|
let put s | quiet = pure ()
|
||||||
|
| otherwise = putStatus s
|
||||||
|
|
||||||
|
ev <- atomically $ readTQueue q
|
||||||
|
|
||||||
|
case ev of
|
||||||
|
ImportIdle -> do
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportSetQuiet qq -> do
|
||||||
|
put ""
|
||||||
|
next qq
|
||||||
|
|
||||||
|
ImportRefLogStart puk -> do
|
||||||
|
put ("wait reflog" <+> pretty (AsBase58 puk))
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportRefLogDone puk Nothing -> do
|
||||||
|
updateSpinner
|
||||||
|
c <- getSpinner
|
||||||
|
put ("wait reflog" <+> pretty (AsBase58 puk) <+> pretty c)
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportRefLogDone _ (Just h) -> do
|
||||||
|
put ("reflog value" <+> pretty h)
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportWaitTx h -> do
|
||||||
|
updateSpinner
|
||||||
|
c <- getSpinner
|
||||||
|
put ("wait tx data" <+> pretty h <+> pretty c)
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportScanTx h -> do
|
||||||
|
put ("scan tx" <+> pretty h)
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportApplyTx h -> do
|
||||||
|
put ("apply tx" <+> pretty h)
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportReadBundleChunk meta (Progress s _) -> do
|
||||||
|
let h = bundleHash meta
|
||||||
|
let e = if bundleEncrypted meta then yellow "@" else ""
|
||||||
|
limit 0.5 $ put $ "read pack" <+> e <> pretty h <+> pretty s
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ExportWriteObject (Progress s _) -> do
|
||||||
|
limit 0.5 $ put $ "write object" <+> pretty s
|
||||||
|
next quiet
|
||||||
|
|
||||||
|
ImportAllDone -> do
|
||||||
|
put "\n"
|
||||||
|
|
||||||
|
loop
|
||||||
|
`finally` do
|
||||||
|
putStatus ""
|
||||||
|
|
||||||
|
where
|
||||||
|
putStatus :: MonadUnliftIO m => Doc AnsiStyle -> m ()
|
||||||
|
putStatus s = do
|
||||||
|
liftIO $ hPutStr stderr $ toStringANSI $ "\r" <> fill 80 "" <> "\r" <> pretty (take 74 (toStringANSI s))
|
||||||
|
liftIO $ hFlush stderr
|
||||||
|
|
||||||
|
runGitCLI :: (GitPerks m) => [GitOption] -> GitCLI m a -> m a
|
||||||
|
runGitCLI o m = do
|
||||||
|
|
||||||
|
soname <- runExceptT getSocketName
|
||||||
|
>>= orThrowUser "no rpc socket"
|
||||||
|
|
||||||
|
flip runContT pure do
|
||||||
|
|
||||||
|
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
||||||
|
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
||||||
|
|
||||||
|
void $ ContT $ withAsync $ runMessagingUnix client
|
||||||
|
|
||||||
|
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||||||
|
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
||||||
|
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||||
|
|
||||||
|
let endpoints = [ Endpoint @UNIX peerAPI
|
||||||
|
, Endpoint @UNIX refLogAPI
|
||||||
|
, Endpoint @UNIX storageAPI
|
||||||
|
]
|
||||||
|
|
||||||
|
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||||
|
|
||||||
|
conf <- lift $ readConfig True
|
||||||
|
|
||||||
|
git <- gitDir
|
||||||
|
>>= orThrowUser "git dir not set"
|
||||||
|
>>= canonicalizePath
|
||||||
|
|
||||||
|
q <- lift newProgressQ
|
||||||
|
let ip = AnyProgress q
|
||||||
|
|
||||||
|
cpath <- lift getConfigDir
|
||||||
|
|
||||||
|
progress <- ContT $ withAsync (drawProgress q)
|
||||||
|
|
||||||
|
env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI storageAPI
|
||||||
|
lift $ runReaderT setupLogging env
|
||||||
|
lift $ withGitEnv env (evolveDB >> m)
|
||||||
|
`finally` do
|
||||||
|
onProgress ip ImportAllDone
|
||||||
|
cancel progress
|
||||||
|
shutDownLogging
|
||||||
|
|
||||||
|
runDefault :: GitPerks m => GitCLI m ()
|
||||||
|
runDefault = do
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
setupLogging :: (GitPerks m, HasGitOpts m) => m ()
|
||||||
|
setupLogging = do
|
||||||
|
|
||||||
|
traceEnv <- liftIO $ lookupEnv "HBS2TRACE" <&> isJust
|
||||||
|
|
||||||
|
setLogging @INFO defLog
|
||||||
|
setLogging @ERROR (logPrefix "" . toStderr)
|
||||||
|
setLogging @WARN (logPrefix "" . toStderr)
|
||||||
|
setLogging @NOTICE (logPrefix "" . toStderr)
|
||||||
|
|
||||||
|
dbg <- debugEnabled
|
||||||
|
|
||||||
|
when (dbg || traceEnv) do
|
||||||
|
setLogging @DEBUG (logPrefix "" . toStderr)
|
||||||
|
|
||||||
|
trc <- traceEnabled
|
||||||
|
|
||||||
|
when (trc || traceEnv) do
|
||||||
|
setLogging @TRACE (logPrefix "" . toStderr)
|
||||||
|
|
||||||
|
shutDownLogging :: MonadUnliftIO m => m ()
|
||||||
|
shutDownLogging = do
|
||||||
|
setLoggingOff @INFO
|
||||||
|
setLoggingOff @ERROR
|
||||||
|
setLoggingOff @WARN
|
||||||
|
setLoggingOff @NOTICE
|
||||||
|
setLoggingOff @DEBUG
|
||||||
|
setLoggingOff @TRACE
|
||||||
|
|
||||||
|
|
@ -0,0 +1,141 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
module HBS2.Git.Client.App.Types
|
||||||
|
( module HBS2.Git.Client.App.Types
|
||||||
|
, module HBS2.Git.Client.App.Types.GitEnv
|
||||||
|
, module HBS2.Git.Local
|
||||||
|
, module Data.Config.Suckless
|
||||||
|
, module Control.Monad.Catch
|
||||||
|
) where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude hiding (info)
|
||||||
|
import HBS2.Git.Client.Progress
|
||||||
|
import HBS2.Git.Local
|
||||||
|
import HBS2.Git.Client.App.Types.GitEnv
|
||||||
|
|
||||||
|
import HBS2.Git.Data.Tx
|
||||||
|
import HBS2.Git.Data.GK
|
||||||
|
|
||||||
|
import HBS2.KeyMan.Keys.Direct
|
||||||
|
import HBS2.Net.Auth.GroupKeySymm
|
||||||
|
import HBS2.Storage.Operations.ByteString
|
||||||
|
import HBS2.System.Dir
|
||||||
|
|
||||||
|
import Data.Config.Suckless
|
||||||
|
import Control.Monad.Catch (MonadThrow(..))
|
||||||
|
import DBPipe.SQLite
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Word
|
||||||
|
|
||||||
|
type Epoch = Word64
|
||||||
|
|
||||||
|
data GitOption = GitTrace
|
||||||
|
| GitDebug
|
||||||
|
| GitExport ExportType
|
||||||
|
| GitEnc ExportEncryption
|
||||||
|
| GitDontApplyHeads
|
||||||
|
deriving stock (Eq,Ord)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
newtype GitCLI m a = GitCLI { fromGitCLI :: ReaderT GitEnv m a }
|
||||||
|
deriving newtype ( Applicative
|
||||||
|
, Functor
|
||||||
|
, Monad
|
||||||
|
, MonadIO
|
||||||
|
, MonadUnliftIO
|
||||||
|
, MonadReader GitEnv
|
||||||
|
, MonadThrow
|
||||||
|
)
|
||||||
|
|
||||||
|
type GitPerks m = ( MonadUnliftIO m, MonadThrow m )
|
||||||
|
|
||||||
|
|
||||||
|
newGitEnv :: GitPerks m
|
||||||
|
=> AnyProgress
|
||||||
|
-> [GitOption]
|
||||||
|
-> FilePath
|
||||||
|
-> FilePath
|
||||||
|
-> Config
|
||||||
|
-> ServiceCaller PeerAPI UNIX
|
||||||
|
-> ServiceCaller RefLogAPI UNIX
|
||||||
|
-> ServiceCaller StorageAPI UNIX
|
||||||
|
-> m GitEnv
|
||||||
|
|
||||||
|
newGitEnv p opts path cpath conf peer reflog sto = do
|
||||||
|
let dbfile = cpath </> "state.db"
|
||||||
|
let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
|
||||||
|
db <- newDBPipeEnv dOpt dbfile
|
||||||
|
cache <- newTVarIO mempty
|
||||||
|
pure $ GitEnv
|
||||||
|
traceOpt
|
||||||
|
debugOpt
|
||||||
|
applyHeadsOpt
|
||||||
|
exportType
|
||||||
|
exportEnc
|
||||||
|
path
|
||||||
|
cpath
|
||||||
|
conf
|
||||||
|
peer
|
||||||
|
reflog
|
||||||
|
(AnyStorage (StorageClient sto))
|
||||||
|
db
|
||||||
|
p
|
||||||
|
cache
|
||||||
|
where
|
||||||
|
traceOpt = GitTrace `elem` opts
|
||||||
|
debugOpt = GitDebug `elem` opts
|
||||||
|
applyHeadsOpt = GitDontApplyHeads `notElem` opts
|
||||||
|
-- FIXME: from-options
|
||||||
|
exportType = lastDef ExportInc [ t | GitExport t <- opts ]
|
||||||
|
exportEnc = lastDef ExportPublic [ t | GitEnc t <- opts ]
|
||||||
|
|
||||||
|
withGitEnv :: GitPerks m => GitEnv -> GitCLI m a -> m a
|
||||||
|
withGitEnv env m = runReaderT (fromGitCLI m) env
|
||||||
|
|
||||||
|
instance (GitPerks m, MonadReader GitEnv m) => GroupKeyOperations m where
|
||||||
|
|
||||||
|
-- FIXME: may-be-faster
|
||||||
|
loadKeyrings gkh = do
|
||||||
|
|
||||||
|
sto <- asks _storage
|
||||||
|
cache <- asks _keyringCache
|
||||||
|
|
||||||
|
let k = gkh
|
||||||
|
|
||||||
|
ke <- readTVarIO cache <&> HM.lookup k
|
||||||
|
|
||||||
|
case ke of
|
||||||
|
Just es -> pure es
|
||||||
|
Nothing -> do
|
||||||
|
|
||||||
|
rcpt <- fromMaybe mempty <$> runMaybeT do
|
||||||
|
runExceptT (readGK0 sto gkh)
|
||||||
|
>>= toMPlus
|
||||||
|
<&> HM.keys . recipients
|
||||||
|
|
||||||
|
es <- runKeymanClient $ do
|
||||||
|
loadKeyRingEntries rcpt
|
||||||
|
<&> fmap snd
|
||||||
|
|
||||||
|
atomically $ modifyTVar cache (HM.insert k es)
|
||||||
|
pure es
|
||||||
|
|
||||||
|
openGroupKey gk = runMaybeT do
|
||||||
|
ke' <- lift $ runKeymanClient do
|
||||||
|
loadKeyRingEntries (HM.keys $ recipients gk)
|
||||||
|
<&> headMay
|
||||||
|
|
||||||
|
(_, KeyringEntry{..}) <- toMPlus ke'
|
||||||
|
|
||||||
|
toMPlus $ lookupGroupKey _krSk _krPk gk
|
||||||
|
|
||||||
|
class HasGitOpts m where
|
||||||
|
debugEnabled :: m Bool
|
||||||
|
traceEnabled :: m Bool
|
||||||
|
|
||||||
|
instance MonadReader GitEnv m => HasGitOpts m where
|
||||||
|
debugEnabled = asks _gitDebugEnabled
|
||||||
|
traceEnabled = asks _gitTraceEnabled
|
||||||
|
|
||||||
|
|
@ -0,0 +1,44 @@
|
||||||
|
{-# Language TemplateHaskell #-}
|
||||||
|
module HBS2.Git.Client.App.Types.GitEnv where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude hiding (info)
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Progress
|
||||||
|
|
||||||
|
import HBS2.Net.Auth.GroupKeySymm
|
||||||
|
|
||||||
|
import Data.Config.Suckless
|
||||||
|
import DBPipe.SQLite
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
|
||||||
|
data ExportType = ExportNew
|
||||||
|
| ExportFork HashRef
|
||||||
|
| ExportInc
|
||||||
|
deriving stock (Eq,Ord,Generic,Show)
|
||||||
|
|
||||||
|
data ExportEncryption =
|
||||||
|
ExportPublic
|
||||||
|
| ExportPrivate FilePath
|
||||||
|
deriving stock (Eq,Ord,Generic,Show)
|
||||||
|
|
||||||
|
type Config = [Syntax C]
|
||||||
|
|
||||||
|
data GitEnv =
|
||||||
|
GitEnv
|
||||||
|
{ _gitTraceEnabled :: Bool
|
||||||
|
, _gitDebugEnabled :: Bool
|
||||||
|
, _gitApplyHeads :: Bool
|
||||||
|
, _gitExportType :: ExportType
|
||||||
|
, _gitExportEnc :: ExportEncryption
|
||||||
|
, _gitPath :: FilePath
|
||||||
|
, _configPath :: FilePath
|
||||||
|
, _config :: Config
|
||||||
|
, _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||||
|
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||||
|
, _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX
|
||||||
|
, _db :: DBPipeEnv
|
||||||
|
, _progress :: AnyProgress
|
||||||
|
, _keyringCache :: TVar (HashMap HashRef [KeyringEntry HBS2Basic])
|
||||||
|
}
|
||||||
|
|
||||||
|
makeLenses 'GitEnv
|
||||||
|
|
@ -0,0 +1,89 @@
|
||||||
|
module HBS2.Git.Client.Config (getConfigDir, readConfig, getManifest, hbs2Name) where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
import HBS2.Git.Client.App.Types
|
||||||
|
|
||||||
|
import HBS2.System.Dir
|
||||||
|
import HBS2.Git.Local.CLI
|
||||||
|
|
||||||
|
import Data.List qualified as L
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.Either
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
|
||||||
|
data ConfigDirNotFound = ConfigDirNotFound
|
||||||
|
deriving stock (Show,Typeable,Generic)
|
||||||
|
|
||||||
|
instance HasErrorStatus ConfigDirNotFound where
|
||||||
|
getStatus = const Failed
|
||||||
|
|
||||||
|
instance Exception ConfigDirNotFound
|
||||||
|
|
||||||
|
hbs2Name :: String
|
||||||
|
hbs2Name = "hbs21"
|
||||||
|
|
||||||
|
getConfigDir :: GitPerks m => m FilePath
|
||||||
|
getConfigDir = do
|
||||||
|
git <- gitDir >>= orThrow ConfigDirNotFound
|
||||||
|
|
||||||
|
let p = splitDirectories git & reverse
|
||||||
|
|
||||||
|
if headMay p == Just ".git" then
|
||||||
|
pure $ joinPath $ reverse (".hbs2-git" : drop 1 p)
|
||||||
|
else do
|
||||||
|
pure $ git </> ".hbs2-git"
|
||||||
|
|
||||||
|
getManifest :: GitPerks m => m (Text, Text, Maybe Text)
|
||||||
|
getManifest = do
|
||||||
|
dir <- getConfigDir
|
||||||
|
let mf = dir </> "manifest"
|
||||||
|
|
||||||
|
let defname = takeFileName (takeDirectory dir) & Text.pack
|
||||||
|
let defbrief = "n/a"
|
||||||
|
|
||||||
|
content <- liftIO (try @_ @IOException $ readFile mf)
|
||||||
|
<&> fromRight ""
|
||||||
|
|
||||||
|
let txt = if L.null content then Nothing else Just (Text.pack content)
|
||||||
|
|
||||||
|
-- FIXME: size-hardcode
|
||||||
|
let header = lines (take 1024 content)
|
||||||
|
& takeWhile ( not . L.null )
|
||||||
|
& unlines
|
||||||
|
& parseTop
|
||||||
|
& fromRight mempty
|
||||||
|
|
||||||
|
let name = lastDef defname [ n | ListVal [ SymbolVal "name:", LitStrVal n ] <- header ]
|
||||||
|
let brief = lastDef defbrief [ n | ListVal [ SymbolVal "brief:", LitStrVal n ] <- header ]
|
||||||
|
|
||||||
|
pure (name,brief,txt)
|
||||||
|
|
||||||
|
readConfig :: (GitPerks m) => Bool -> m Config
|
||||||
|
readConfig canTouch = do
|
||||||
|
{- HLINT ignore "Functor law" -}
|
||||||
|
confPath <- getConfigDir
|
||||||
|
let confRoot = confPath </> "config"
|
||||||
|
|
||||||
|
when canTouch do
|
||||||
|
|
||||||
|
here <- doesPathExist confRoot
|
||||||
|
|
||||||
|
unless here do
|
||||||
|
mkdir confPath
|
||||||
|
liftIO $ writeFile confRoot defConf
|
||||||
|
|
||||||
|
try @_ @SomeException (liftIO (readFile confRoot))
|
||||||
|
<&> fromRight mempty
|
||||||
|
<&> parseTop
|
||||||
|
<&> fromRight mempty
|
||||||
|
|
||||||
|
|
||||||
|
defConf :: String
|
||||||
|
defConf = [qc|;; hbs2-git config file
|
||||||
|
; those branches will be replicated by default
|
||||||
|
export include "refs/heads/master"
|
||||||
|
export include "refs/heads/main"
|
||||||
|
export exclude "refs/heads/*"
|
||||||
|
export tags
|
||||||
|
|]
|
||||||
|
|
@ -0,0 +1,293 @@
|
||||||
|
module HBS2.Git.Client.Export (export) where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude hiding (info)
|
||||||
|
import HBS2.Git.Client.App.Types
|
||||||
|
import HBS2.Git.Client.Config
|
||||||
|
import HBS2.Git.Client.RefLog
|
||||||
|
import HBS2.Git.Client.State
|
||||||
|
import HBS2.Git.Client.Progress
|
||||||
|
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
import HBS2.Git.Data.Tx
|
||||||
|
import HBS2.Git.Data.GK
|
||||||
|
|
||||||
|
import HBS2.Git.Local.CLI
|
||||||
|
|
||||||
|
import HBS2.Storage.Operations.ByteString
|
||||||
|
import HBS2.System.Dir
|
||||||
|
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||||
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
import Data.ByteString.Builder as B
|
||||||
|
import Data.HashSet qualified as HashSet
|
||||||
|
import Data.HashMap.Strict qualified as HashMap
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.List qualified as L
|
||||||
|
import Data.Ord (comparing)
|
||||||
|
import Data.Either
|
||||||
|
|
||||||
|
data ExportError = ExportUnsupportedOperation
|
||||||
|
| ExportBundleCreateError
|
||||||
|
deriving stock (Show,Typeable)
|
||||||
|
|
||||||
|
instance Exception ExportError
|
||||||
|
|
||||||
|
instance HasErrorStatus ExportError where
|
||||||
|
getStatus = \case
|
||||||
|
ExportUnsupportedOperation -> Failed
|
||||||
|
|
||||||
|
instance ToFilePath (GitRef, GitHash) where
|
||||||
|
toFilePath (g, r) = show (pretty g)
|
||||||
|
|
||||||
|
{-# ANN module "HLint: ignore Eta reduce" #-}
|
||||||
|
filterPat :: ToFilePath a => [FilePattern] -> [FilePattern] -> [a] -> [a]
|
||||||
|
filterPat inc excl refs = filter check refs
|
||||||
|
where
|
||||||
|
check r = i || not e
|
||||||
|
where
|
||||||
|
e = not $ L.null $ catMaybes [ match p (toFilePath r) | p <- excl ]
|
||||||
|
i = not $ L.null $ catMaybes [ match p (toFilePath r) | p <- inc ]
|
||||||
|
|
||||||
|
refsForExport :: (MonadReader GitEnv m, MonadIO m) => [(GitRef, Maybe GitHash)] -> m [(GitRef,GitHash)]
|
||||||
|
|
||||||
|
refsForExport forPushL = do
|
||||||
|
{- HLINT ignore "Functor law" -}
|
||||||
|
|
||||||
|
conf <- asks _config
|
||||||
|
path <- asks _gitPath
|
||||||
|
|
||||||
|
let tags = headDef mempty [ "--tags" :: String | (ListVal [SymbolVal "export", SymbolVal "tags"] ) <- conf]
|
||||||
|
|
||||||
|
let incl = [ Text.unpack p
|
||||||
|
| (ListVal [SymbolVal "export", SymbolVal "include", LitStrVal p]) <- conf
|
||||||
|
]
|
||||||
|
|
||||||
|
let excl = [ Text.unpack p
|
||||||
|
| (ListVal [SymbolVal "export", SymbolVal "exclude", LitStrVal p]) <- conf
|
||||||
|
]
|
||||||
|
|
||||||
|
let forPush = [ (k,v) | (k, Just v) <- forPushL ] & HashMap.fromList
|
||||||
|
|
||||||
|
let deleted = [ k | (k, Nothing) <- forPushL ] & HashSet.fromList
|
||||||
|
|
||||||
|
debug $ red "CONF" <> pretty path <> line <> indent 2 (vcat (fmap pretty conf))
|
||||||
|
|
||||||
|
let cmd = [qc|git --git-dir={path} show-ref {tags} --heads --head|]
|
||||||
|
|
||||||
|
debug $ red "CMD" <+> pretty cmd
|
||||||
|
debug $ "FILTERS" <+> pretty (incl, excl)
|
||||||
|
debug $ red "DELETED" <+> pretty (HashSet.toList deleted)
|
||||||
|
debug $ red "FOR-PUSH" <+> pretty (HashMap.toList forPush)
|
||||||
|
|
||||||
|
-- мы экспортируем всегда HEAD что бы правильно работал git clone
|
||||||
|
-- поэтому мы экспортируем и текущий бранч тоже
|
||||||
|
-- даже если он запрещён фильтрами
|
||||||
|
|
||||||
|
currentBranch <- gitRunCommand [qc|git --git-dir={path} symbolic-ref HEAD|]
|
||||||
|
>>= orThrowUser "can't read HEAD 1"
|
||||||
|
<&> GitRef . BS8.strip . LBS8.toStrict
|
||||||
|
|
||||||
|
currentVal <- gitRunCommand [qc|git --git-dir={path} rev-parse {pretty currentBranch}|]
|
||||||
|
>>= orThrowUser "can't read HEAD 2"
|
||||||
|
<&> (BS8.unpack . BS8.strip . LBS8.toStrict)
|
||||||
|
<&> fromStringMay @GitHash
|
||||||
|
>>= orThrowUser "invalid git hash for HEAD"
|
||||||
|
|
||||||
|
gitRunCommand cmd
|
||||||
|
>>= orThrowUser ("can't read git repo" <+> pretty path)
|
||||||
|
<&> LBS8.lines
|
||||||
|
<&> fmap LBS8.words
|
||||||
|
<&> mapMaybe \case
|
||||||
|
[val,name] -> (GitRef (LBS8.toStrict name),) <$> fromStringMay @GitHash (LBS8.unpack val)
|
||||||
|
_ -> Nothing
|
||||||
|
<&> filterPat incl excl
|
||||||
|
<&> HashMap.fromList
|
||||||
|
<&> HashMap.filterWithKey (\k _ -> not (HashSet.member k deleted))
|
||||||
|
<&> mappend forPush
|
||||||
|
<&> mappend (HashMap.singleton currentBranch currentVal)
|
||||||
|
<&> HashMap.toList
|
||||||
|
<&> L.sortBy orderRefs
|
||||||
|
|
||||||
|
where
|
||||||
|
orderRefs (GitRef "HEAD", _) _ = LT
|
||||||
|
orderRefs _ (GitRef "HEAD", _) = GT
|
||||||
|
orderRefs x y = comparing fst x y
|
||||||
|
|
||||||
|
loadNewGK0 :: (MonadIO m, MonadReader GitEnv m)
|
||||||
|
=> RefLogId
|
||||||
|
-> Maybe HashRef
|
||||||
|
-> m (Maybe (HashRef,Epoch))
|
||||||
|
|
||||||
|
loadNewGK0 r = \case
|
||||||
|
Nothing -> storeNewGK0
|
||||||
|
|
||||||
|
Just tx0 -> do
|
||||||
|
href <- storeNewGK0
|
||||||
|
withState do
|
||||||
|
for_ href (insertNewGK0 r tx0 . fst)
|
||||||
|
commitAll
|
||||||
|
|
||||||
|
withState $ selectNewGK0 r
|
||||||
|
|
||||||
|
storeNewGK0 :: (MonadIO m, MonadReader GitEnv m) => m (Maybe (HashRef,Epoch))
|
||||||
|
storeNewGK0 = do
|
||||||
|
sto <- asks _storage
|
||||||
|
enc <- asks _gitExportEnc
|
||||||
|
runMaybeT do
|
||||||
|
gkf <- headMay [ f | ExportPrivate f <- [enc] ] & toMPlus
|
||||||
|
gk <- loadGK0FromFile gkf >>= toMPlus
|
||||||
|
epoch <- getEpoch
|
||||||
|
writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch)
|
||||||
|
|
||||||
|
export :: (GitPerks m, MonadReader GitEnv m, GroupKeyOperations m)
|
||||||
|
=> RefLogId
|
||||||
|
-> [(GitRef,Maybe GitHash)]
|
||||||
|
-> m ()
|
||||||
|
export puk refs = do
|
||||||
|
|
||||||
|
subscribeRefLog puk
|
||||||
|
|
||||||
|
git <- asks _gitPath
|
||||||
|
sto <- asks _storage
|
||||||
|
new <- asks _gitExportType <&> (== ExportNew)
|
||||||
|
reflog <- asks _refLogAPI
|
||||||
|
ip <- asks _progress
|
||||||
|
|
||||||
|
myrefs <- refsForExport refs
|
||||||
|
|
||||||
|
let myrefsKey = L.sortOn fst myrefs & serialise & hashObject @HbSync & HashRef
|
||||||
|
|
||||||
|
flip runContT pure do
|
||||||
|
callCC \exit -> do
|
||||||
|
|
||||||
|
|
||||||
|
tx0 <- getLastAppliedTx
|
||||||
|
|
||||||
|
rh0 <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus )
|
||||||
|
|
||||||
|
(name,brief,mf) <- lift getManifest
|
||||||
|
|
||||||
|
gk0new0 <- loadNewGK0 puk tx0
|
||||||
|
|
||||||
|
let gk0old = _repoHeadGK0 =<< rh0
|
||||||
|
|
||||||
|
mbTxTime0 <- runMaybeT $ toMPlus tx0
|
||||||
|
>>= withState .selectTxForRefLog puk
|
||||||
|
>>= toMPlus
|
||||||
|
|
||||||
|
-- смотрим, какое время ключа для данного рефлога, т.к. голова-то
|
||||||
|
-- может быть одна, а вот рефлоги -- разные
|
||||||
|
-- если мы успели --- то накатываем свой ключ.
|
||||||
|
-- если нет -- придется повторить
|
||||||
|
let gk0new = if (snd <$> gk0new0) > (snd <$> mbTxTime0) then
|
||||||
|
fst <$> gk0new0
|
||||||
|
else
|
||||||
|
gk0old
|
||||||
|
|
||||||
|
let gk0 = gk0new <|> gk0old
|
||||||
|
|
||||||
|
repohead <- makeRepoHeadSimple name brief mf gk0 myrefs
|
||||||
|
|
||||||
|
let oldRefs = maybe mempty _repoHeadRefs rh0
|
||||||
|
|
||||||
|
trace $ "TX0" <+> pretty tx0
|
||||||
|
|
||||||
|
bss <- maybe (pure mempty) txBundles tx0
|
||||||
|
|
||||||
|
objs <- lift enumAllGitObjects
|
||||||
|
>>= withState . filterM (notInTx tx0)
|
||||||
|
|
||||||
|
when (null objs && not new && oldRefs == myrefs) do
|
||||||
|
exit ()
|
||||||
|
|
||||||
|
debug $ red "REFS-FOR-EXPORT:" <+> pretty myrefs
|
||||||
|
|
||||||
|
done <- withState (selectBundleByKey puk myrefsKey)
|
||||||
|
|
||||||
|
out <-
|
||||||
|
if isJust done && not new then do
|
||||||
|
pure []
|
||||||
|
|
||||||
|
else do
|
||||||
|
|
||||||
|
p <- ContT $ withGitPack
|
||||||
|
|
||||||
|
for_ (zip [1..] objs) $ \(n,o) -> do
|
||||||
|
onProgress ip (ExportWriteObject (Progress n Nothing))
|
||||||
|
liftIO $ LBS8.hPutStrLn (getStdin p) (LBS8.pack $ show $ pretty o)
|
||||||
|
|
||||||
|
code <- hFlush (getStdin p) >> hClose (getStdin p) >> getExitCode p
|
||||||
|
|
||||||
|
let idx = serialise objs
|
||||||
|
let size = B.word32BE (fromIntegral $ LBS.length idx)
|
||||||
|
let hdr = B.word32BE 1
|
||||||
|
pack <- liftIO $ LBS.hGetContents (getStdout p)
|
||||||
|
let out = B.toLazyByteString ( size <> hdr <> B.lazyByteString idx <> B.lazyByteString pack )
|
||||||
|
pure [out]
|
||||||
|
|
||||||
|
rank <- getEpoch <&> fromIntegral
|
||||||
|
|
||||||
|
let rw = gk0new /= gk0old
|
||||||
|
|
||||||
|
debug $ red "MAKE TX" <+> pretty rw <+> pretty gk0old <+> "->" <+> pretty gk0new
|
||||||
|
|
||||||
|
tx <- lift $ makeTx sto rw rank puk repohead bss out
|
||||||
|
|
||||||
|
r <- lift $ race (pause @'Seconds 1) (callService @RpcRefLogPost reflog tx)
|
||||||
|
>>= orThrowUser "hbs2-peer rpc timeout"
|
||||||
|
|
||||||
|
when (isLeft r) $ exit ()
|
||||||
|
|
||||||
|
void $ runMaybeT do
|
||||||
|
(_,_,bh) <- unpackTx tx
|
||||||
|
withState (insertBundleKey puk myrefsKey bh)
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
|
||||||
|
notInTx Nothing _ = pure True
|
||||||
|
notInTx (Just tx0) obj = not <$> isObjectInTx tx0 obj
|
||||||
|
|
||||||
|
getLastAppliedTx = runMaybeT do
|
||||||
|
(tx0,_) <- withState selectMaxAppliedTx
|
||||||
|
>>= toMPlus
|
||||||
|
pure tx0
|
||||||
|
|
||||||
|
txBundles tx0 = withDef =<< runMaybeT do
|
||||||
|
|
||||||
|
new <- asks _gitExportType <&> (== ExportNew)
|
||||||
|
sto <- asks _storage
|
||||||
|
|
||||||
|
txbody <- runExceptT (readTx sto tx0)
|
||||||
|
>>= orThrowUser ("missed blocks for tx" <+> pretty tx0)
|
||||||
|
|
||||||
|
let bref = view _4 txbody
|
||||||
|
|
||||||
|
readBundleRefs sto bref
|
||||||
|
>>= orThrowUser ("missed blocks for tx" <+> pretty tx0)
|
||||||
|
|
||||||
|
where
|
||||||
|
withDef Nothing = pure mempty
|
||||||
|
withDef (Just x) = pure x
|
||||||
|
|
||||||
|
enumAllGitObjects :: (GitPerks m, MonadReader GitEnv m) => m [GitHash]
|
||||||
|
enumAllGitObjects = do
|
||||||
|
path <- asks _gitPath
|
||||||
|
let rcmd = [qc|git --git-dir {path} cat-file --batch-check='%(objectname)' --batch-all-objects|]
|
||||||
|
(_, out, _) <- liftIO $ readProcess (shell rcmd)
|
||||||
|
pure $ LBS8.lines out & mapMaybe (fromStringMay @GitHash . LBS8.unpack)
|
||||||
|
|
||||||
|
|
||||||
|
withGitPack :: (GitPerks m, MonadReader GitEnv m) => (Process Handle Handle () -> m a) -> m a
|
||||||
|
withGitPack action = do
|
||||||
|
fp <- asks _gitPath
|
||||||
|
let cmd = "git"
|
||||||
|
let args = ["--git-dir", fp, "pack-objects", "--stdout", "-q"]
|
||||||
|
let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
|
||||||
|
p <- startProcess config
|
||||||
|
action p
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,292 @@
|
||||||
|
module HBS2.Git.Client.Import where
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude hiding (info)
|
||||||
|
import HBS2.Git.Client.App.Types
|
||||||
|
import HBS2.Git.Client.Config
|
||||||
|
import HBS2.Git.Client.State
|
||||||
|
import HBS2.Git.Client.RefLog
|
||||||
|
import HBS2.Git.Client.Progress
|
||||||
|
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
import HBS2.Git.Data.Tx
|
||||||
|
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
import System.IO (hPrint)
|
||||||
|
import System.Environment
|
||||||
|
import System.Exit
|
||||||
|
|
||||||
|
data ImportRefLogNotFound = ImportRefLogNotFound
|
||||||
|
deriving stock (Typeable,Show)
|
||||||
|
|
||||||
|
|
||||||
|
instance Exception ImportRefLogNotFound
|
||||||
|
|
||||||
|
data ImportTxError =
|
||||||
|
ImportTxReadError HashRef
|
||||||
|
| ImportOpError OperationError
|
||||||
|
| ImportUnbundleError HashRef
|
||||||
|
| ImportMissed HashRef
|
||||||
|
deriving stock (Typeable)
|
||||||
|
|
||||||
|
instance Show ImportTxError where
|
||||||
|
show (ImportTxReadError h) = [qc|ImportTxError {pretty h}|]
|
||||||
|
show (ImportOpError o) = show o
|
||||||
|
show (ImportUnbundleError h) = [qc|ImportUnbundleError {pretty h}|]
|
||||||
|
show (ImportMissed h) = [qc|ImportMissed {pretty h}|]
|
||||||
|
|
||||||
|
instance Exception ImportTxError
|
||||||
|
|
||||||
|
data IState =
|
||||||
|
IWaitRefLog Int
|
||||||
|
| IScanRefLog HashRef
|
||||||
|
| IApplyTx HashRef
|
||||||
|
| IExit
|
||||||
|
|
||||||
|
importRepoWait :: (GitPerks m, MonadReader GitEnv m)
|
||||||
|
=> RefLogId
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
importRepoWait puk = do
|
||||||
|
|
||||||
|
env <- ask
|
||||||
|
|
||||||
|
subscribeRefLog puk
|
||||||
|
|
||||||
|
ip <- asks _progress
|
||||||
|
|
||||||
|
flip fix (IWaitRefLog 20) $ \next -> \case
|
||||||
|
IWaitRefLog w | w <= 0 -> do
|
||||||
|
throwIO ImportRefLogNotFound
|
||||||
|
|
||||||
|
IWaitRefLog w -> do
|
||||||
|
onProgress ip (ImportRefLogStart puk)
|
||||||
|
try @_ @SomeException (getRefLogMerkle puk) >>= \case
|
||||||
|
Left _ -> do
|
||||||
|
onProgress ip (ImportRefLogDone puk Nothing)
|
||||||
|
pause @'Seconds 2
|
||||||
|
next (IWaitRefLog (pred w))
|
||||||
|
|
||||||
|
Right Nothing -> do
|
||||||
|
onProgress ip (ImportRefLogDone puk Nothing)
|
||||||
|
pause @'Seconds 2
|
||||||
|
next (IWaitRefLog (pred w))
|
||||||
|
|
||||||
|
Right (Just h) -> do
|
||||||
|
onProgress ip (ImportRefLogDone puk (Just h))
|
||||||
|
next (IScanRefLog h)
|
||||||
|
|
||||||
|
IScanRefLog h -> do
|
||||||
|
scanRefLog puk h
|
||||||
|
withState (selectMaxSeqTxNotDone puk) >>= \case
|
||||||
|
Just tx -> next (IApplyTx tx)
|
||||||
|
Nothing -> do
|
||||||
|
hasAnyTx <- withState existsAnyTxDone
|
||||||
|
|
||||||
|
if hasAnyTx then -- existing repo, is' a fetch
|
||||||
|
next IExit
|
||||||
|
else do
|
||||||
|
void $ race (pause @'Seconds 10) do
|
||||||
|
forever do
|
||||||
|
onProgress ip (ImportWaitTx h)
|
||||||
|
pause @'Seconds 0.25
|
||||||
|
|
||||||
|
next (IScanRefLog h)
|
||||||
|
|
||||||
|
IApplyTx h -> do
|
||||||
|
onProgress ip (ImportApplyTx h)
|
||||||
|
r <- runExceptT (applyTx h)
|
||||||
|
case r of
|
||||||
|
|
||||||
|
Left MissedBlockError -> do
|
||||||
|
next =<< repeatOrExit
|
||||||
|
|
||||||
|
Left IncompleteData -> do
|
||||||
|
next =<< repeatOrExit
|
||||||
|
|
||||||
|
Left e -> do
|
||||||
|
err (line <> red (viaShow e))
|
||||||
|
throwIO (userError "tx apply / state read error")
|
||||||
|
|
||||||
|
Right{} -> next IExit
|
||||||
|
|
||||||
|
IExit -> do
|
||||||
|
onProgress ip (ImportSetQuiet True)
|
||||||
|
onProgress ip ImportAllDone
|
||||||
|
|
||||||
|
|
||||||
|
where
|
||||||
|
repeatOrExit = do
|
||||||
|
hasAnyTx <- withState existsAnyTxDone
|
||||||
|
if hasAnyTx then do
|
||||||
|
pure IExit
|
||||||
|
else do
|
||||||
|
pause @'Seconds 2
|
||||||
|
pure (IWaitRefLog 5)
|
||||||
|
|
||||||
|
|
||||||
|
scanRefLog :: (GitPerks m, MonadReader GitEnv m)
|
||||||
|
=> RefLogId
|
||||||
|
-> HashRef
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
scanRefLog puk rv = do
|
||||||
|
sto <- asks _storage
|
||||||
|
ip <- asks _progress
|
||||||
|
env <- ask
|
||||||
|
|
||||||
|
txs <- S.toList_ $ do
|
||||||
|
walkMerkle @[HashRef] (fromHashRef rv) (getBlock sto) $ \case
|
||||||
|
Left he -> do
|
||||||
|
err $ red "missed block" <+> pretty he
|
||||||
|
|
||||||
|
Right hxs -> do
|
||||||
|
for_ hxs $ \htx -> do
|
||||||
|
here <- lift (withState (existsTx htx))
|
||||||
|
unless here (S.yield htx)
|
||||||
|
|
||||||
|
tx <- liftIO $ S.toList_ $ do
|
||||||
|
for_ txs $ \tx -> do
|
||||||
|
onProgress ip (ImportScanTx tx)
|
||||||
|
runExceptT (readTx sto tx <&> (tx,))
|
||||||
|
>>= either (const none) S.yield
|
||||||
|
|
||||||
|
withState $ transactional do
|
||||||
|
for_ tx $ \(th,(n,rhh,rh,bundleh)) -> do
|
||||||
|
-- notice $ red "TX" <+> pretty th <+> pretty n
|
||||||
|
insertTx puk th n rhh bundleh
|
||||||
|
|
||||||
|
|
||||||
|
applyTx :: (GitPerks m, MonadReader GitEnv m, MonadError OperationError m)
|
||||||
|
=> HashRef
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
applyTx h = do
|
||||||
|
sto <- asks _storage
|
||||||
|
(n,rhh,r,bunh) <- readTx sto h
|
||||||
|
|
||||||
|
bundles <- readBundleRefs sto bunh
|
||||||
|
>>= orThrowError IncompleteData
|
||||||
|
|
||||||
|
trace $ red "applyTx" <+> pretty h <+> pretty h <+> pretty bundles
|
||||||
|
|
||||||
|
withState $ transactional do
|
||||||
|
|
||||||
|
applyBundles r bundles
|
||||||
|
|
||||||
|
app <- lift $ asks (view gitApplyHeads)
|
||||||
|
|
||||||
|
when app do
|
||||||
|
lift $ applyHeads r
|
||||||
|
|
||||||
|
insertTxDone h
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
applyHeads rh = do
|
||||||
|
|
||||||
|
let refs = _repoHeadRefs rh
|
||||||
|
|
||||||
|
withGitFastImport $ \ps -> do
|
||||||
|
let psin = getStdin ps
|
||||||
|
|
||||||
|
for_ refs $ \(r,v) -> do
|
||||||
|
unless (r == GitRef "HEAD") do
|
||||||
|
liftIO $ hPrint psin $
|
||||||
|
"reset" <+> pretty r <> line <> "from" <+> pretty v <> line
|
||||||
|
|
||||||
|
hClose psin
|
||||||
|
code <- waitExitCode ps
|
||||||
|
|
||||||
|
trace $ red "git fast-import status" <+> viaShow code
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
applyBundles r bundles = do
|
||||||
|
env <- lift ask
|
||||||
|
sto <- lift $ asks _storage
|
||||||
|
ip <- lift $ asks _progress
|
||||||
|
|
||||||
|
-- withState $ do
|
||||||
|
for_ (zip [0..] bundles) $ \(n,bu) -> do
|
||||||
|
|
||||||
|
insertTxBundle h n bu
|
||||||
|
|
||||||
|
here <- existsBundleDone bu
|
||||||
|
|
||||||
|
unless here do
|
||||||
|
|
||||||
|
BundleWithMeta meta bytes <- lift (runExceptT $ readBundle sto r bu)
|
||||||
|
>>= orThrow (ImportUnbundleError bu)
|
||||||
|
|
||||||
|
(_,_,idx,lbs) <- unpackPackMay bytes
|
||||||
|
& orThrow (ImportUnbundleError bu)
|
||||||
|
|
||||||
|
trace $ red "reading bundle" <+> pretty bu -- <+> pretty (LBS.length lbs)
|
||||||
|
|
||||||
|
for_ idx $ \i -> do
|
||||||
|
insertBundleObject bu i
|
||||||
|
|
||||||
|
let chunks = LBS.toChunks lbs
|
||||||
|
|
||||||
|
void $ liftIO $ withGitEnv env $ withGitUnpack $ \p -> do
|
||||||
|
let pstdin = getStdin p
|
||||||
|
for_ (zip [1..] chunks) $ \(i,chu) -> do
|
||||||
|
onProgress ip (ImportReadBundleChunk meta (Progress i Nothing))
|
||||||
|
liftIO $ LBS.hPutStr pstdin (LBS.fromStrict chu)
|
||||||
|
|
||||||
|
hFlush pstdin >> hClose pstdin
|
||||||
|
|
||||||
|
code <- waitExitCode p
|
||||||
|
|
||||||
|
trace $ "unpack objects done:" <+> viaShow code
|
||||||
|
|
||||||
|
insertBundleDone bu
|
||||||
|
|
||||||
|
|
||||||
|
withGitFastImport :: (MonadUnliftIO m, MonadReader GitEnv m)
|
||||||
|
=> (Process Handle Handle () -> m a)
|
||||||
|
-> m ()
|
||||||
|
withGitFastImport action = do
|
||||||
|
fp <- asks _gitPath
|
||||||
|
let cmd = "git"
|
||||||
|
let args = ["--git-dir", fp, "fast-import"]
|
||||||
|
-- let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
|
||||||
|
|
||||||
|
trc <- asks traceEnabled >>= \case
|
||||||
|
True -> pure id
|
||||||
|
False -> pure $ setStdout closed . setStderr closed
|
||||||
|
|
||||||
|
let pconfig = setStdin createPipe $ setStdout createPipe $ trc $ proc cmd args
|
||||||
|
p <- startProcess pconfig
|
||||||
|
void $ action p
|
||||||
|
stopProcess p
|
||||||
|
|
||||||
|
withGitUnpack :: (MonadUnliftIO m, MonadReader GitEnv m)
|
||||||
|
=> (Process Handle Handle () -> m a) -> m a
|
||||||
|
withGitUnpack action = do
|
||||||
|
fp <- asks _gitPath
|
||||||
|
let cmd = "git"
|
||||||
|
let args = ["--git-dir", fp, "unpack-objects", "-q"]
|
||||||
|
|
||||||
|
trc <- asks traceEnabled >>= \case
|
||||||
|
True -> pure id
|
||||||
|
False -> pure $ setStdout closed . setStderr closed
|
||||||
|
|
||||||
|
let pconfig = setStdin createPipe $ setStdout createPipe $ trc $ proc cmd args
|
||||||
|
p <- startProcess pconfig
|
||||||
|
action p
|
||||||
|
|
||||||
|
|
||||||
|
gitPrune :: (MonadUnliftIO m, MonadReader GitEnv m)
|
||||||
|
=> m ()
|
||||||
|
gitPrune = do
|
||||||
|
fp <- asks _gitPath
|
||||||
|
let cmd = [qc|git --git-dir={fp} prune|]
|
||||||
|
runProcess_ (shell cmd & setStderr closed & setStdout closed)
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,88 @@
|
||||||
|
module HBS2.Git.Client.Prelude
|
||||||
|
( module HBS2.Prelude.Plated
|
||||||
|
, module HBS2.Base58
|
||||||
|
, module HBS2.Clock
|
||||||
|
, module HBS2.Hash
|
||||||
|
, module HBS2.Data.Types.Refs
|
||||||
|
, module HBS2.Net.Auth.Credentials
|
||||||
|
, module HBS2.Merkle
|
||||||
|
, module HBS2.Storage
|
||||||
|
, module HBS2.Net.Messaging.Unix
|
||||||
|
, module HBS2.OrDie
|
||||||
|
, module HBS2.Misc.PrettyStuff
|
||||||
|
, module HBS2.System.Logger.Simple.ANSI
|
||||||
|
|
||||||
|
-- peer
|
||||||
|
, module HBS2.Net.Proto.Service
|
||||||
|
, module HBS2.Peer.RPC.API.Peer
|
||||||
|
, module HBS2.Peer.RPC.API.RefLog
|
||||||
|
, module HBS2.Peer.RPC.API.Storage
|
||||||
|
, module HBS2.Peer.RPC.Client.StorageClient
|
||||||
|
|
||||||
|
, module Control.Applicative
|
||||||
|
, module Control.Monad.Reader
|
||||||
|
, module Control.Monad.Trans.Cont
|
||||||
|
, module Control.Monad.Trans.Maybe
|
||||||
|
, module System.Process.Typed
|
||||||
|
, module Control.Monad.Except
|
||||||
|
, module Lens.Micro.Platform
|
||||||
|
, module UnliftIO
|
||||||
|
|
||||||
|
, getSocketName
|
||||||
|
, formatRef
|
||||||
|
, deserialiseOrFail
|
||||||
|
) where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated hiding (at)
|
||||||
|
import HBS2.Base58
|
||||||
|
import HBS2.Clock
|
||||||
|
|
||||||
|
import HBS2.Peer.Proto
|
||||||
|
|
||||||
|
import HBS2.Hash
|
||||||
|
import HBS2.Data.Types.Refs
|
||||||
|
import HBS2.Net.Auth.Credentials
|
||||||
|
import HBS2.Merkle
|
||||||
|
import HBS2.Storage
|
||||||
|
import HBS2.OrDie
|
||||||
|
import HBS2.Misc.PrettyStuff
|
||||||
|
import HBS2.System.Logger.Simple.ANSI
|
||||||
|
|
||||||
|
import HBS2.Net.Messaging.Unix
|
||||||
|
import HBS2.Net.Proto.Service
|
||||||
|
|
||||||
|
import HBS2.Peer.RPC.API.Peer
|
||||||
|
import HBS2.Peer.RPC.API.RefLog
|
||||||
|
import HBS2.Peer.RPC.API.Storage
|
||||||
|
import HBS2.Peer.RPC.Client.StorageClient
|
||||||
|
|
||||||
|
import HBS2.Peer.CLI.Detect
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Monad.Trans.Cont
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Control.Exception
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import UnliftIO
|
||||||
|
import System.Process.Typed
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import Codec.Serialise
|
||||||
|
|
||||||
|
data RPCNotFoundError = RPCNotFoundError
|
||||||
|
deriving stock (Show,Typeable)
|
||||||
|
|
||||||
|
|
||||||
|
instance Exception RPCNotFoundError
|
||||||
|
|
||||||
|
instance HasErrorStatus RPCNotFoundError where
|
||||||
|
getStatus = const Failed
|
||||||
|
|
||||||
|
getSocketName :: forall m . (MonadUnliftIO m, MonadError RPCNotFoundError m) => m FilePath
|
||||||
|
getSocketName = do
|
||||||
|
detectRPC >>= maybe (throwError RPCNotFoundError) pure
|
||||||
|
|
||||||
|
|
||||||
|
formatRef :: (Pretty a1, Pretty a2) => (a1, a2) -> Doc ann
|
||||||
|
formatRef (r,h) = pretty h <+> pretty r
|
||||||
|
|
||||||
|
|
@ -0,0 +1,52 @@
|
||||||
|
{-# Language TemplateHaskell #-}
|
||||||
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
|
module HBS2.Git.Client.Progress where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
|
||||||
|
import HBS2.Git.Data.Tx
|
||||||
|
|
||||||
|
data Progress a =
|
||||||
|
Progress
|
||||||
|
{ _progressState :: a
|
||||||
|
, _progressTotal :: Maybe a
|
||||||
|
}
|
||||||
|
deriving (Eq,Generic)
|
||||||
|
|
||||||
|
makeLenses 'Progress
|
||||||
|
|
||||||
|
class HasProgress a where
|
||||||
|
onProgress :: MonadIO m => a -> ProgressEvent -> m ()
|
||||||
|
|
||||||
|
data ProgressEvent =
|
||||||
|
ImportIdle
|
||||||
|
| ImportRefLogStart RefLogId
|
||||||
|
| ImportRefLogDone RefLogId (Maybe HashRef)
|
||||||
|
| ImportWaitTx HashRef
|
||||||
|
| ImportScanTx HashRef
|
||||||
|
| ImportApplyTx HashRef
|
||||||
|
| ImportReadBundleChunk BundleMeta (Progress Int)
|
||||||
|
| ImportSetQuiet Bool
|
||||||
|
| ImportAllDone
|
||||||
|
| ExportWriteObject (Progress Int)
|
||||||
|
|
||||||
|
|
||||||
|
data AnyProgress = forall a . HasProgress a => AnyProgress a
|
||||||
|
|
||||||
|
instance HasProgress AnyProgress where
|
||||||
|
onProgress (AnyProgress e) = onProgress e
|
||||||
|
|
||||||
|
instance HasProgress () where
|
||||||
|
onProgress _ _ = pure ()
|
||||||
|
|
||||||
|
newtype ProgressQ = ProgressQ (TQueue ProgressEvent)
|
||||||
|
|
||||||
|
instance HasProgress ProgressQ where
|
||||||
|
onProgress (ProgressQ q) ev = atomically (writeTQueue q ev)
|
||||||
|
|
||||||
|
newProgressQ :: MonadUnliftIO m => m ProgressQ
|
||||||
|
newProgressQ = ProgressQ <$> newTQueueIO
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,37 @@
|
||||||
|
module HBS2.Git.Client.RefLog where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
import HBS2.Git.Client.App.Types
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
|
||||||
|
data RefLogRequestTimeout = RefLogRequestTimeout
|
||||||
|
deriving (Show,Typeable)
|
||||||
|
|
||||||
|
data RefLogRequestError = RefLogRequestError
|
||||||
|
deriving (Show,Typeable)
|
||||||
|
|
||||||
|
instance Exception RefLogRequestTimeout
|
||||||
|
|
||||||
|
instance Exception RefLogRequestError
|
||||||
|
|
||||||
|
subscribeRefLog :: (GitPerks m, MonadReader GitEnv m) => RefLogId -> m ()
|
||||||
|
subscribeRefLog puk = do
|
||||||
|
api <- asks _peerAPI
|
||||||
|
void $ callService @RpcPollAdd api (puk, "reflog", 13)
|
||||||
|
|
||||||
|
|
||||||
|
getRefLogMerkle :: (GitPerks m, MonadReader GitEnv m) => RefLogId -> m (Maybe HashRef)
|
||||||
|
getRefLogMerkle puk = do
|
||||||
|
|
||||||
|
api <- asks _refLogAPI
|
||||||
|
|
||||||
|
void $ race (pause @'Seconds 1) (callService @RpcRefLogFetch api puk)
|
||||||
|
>>= orThrow RefLogRequestTimeout
|
||||||
|
>>= orThrow RefLogRequestError
|
||||||
|
|
||||||
|
race (pause @'Seconds 1) (callService @RpcRefLogGet api puk)
|
||||||
|
>>= orThrow RefLogRequestTimeout
|
||||||
|
>>= orThrow RefLogRequestError
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,348 @@
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
module HBS2.Git.Client.State
|
||||||
|
( module HBS2.Git.Client.State
|
||||||
|
, transactional
|
||||||
|
, commitAll
|
||||||
|
) where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
import HBS2.Git.Client.App.Types
|
||||||
|
import HBS2.Git.Client.Config
|
||||||
|
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
|
||||||
|
import DBPipe.SQLite
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.List qualified as List
|
||||||
|
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
|
||||||
|
newtype Base58Field a = Base58Field { fromBase58Field :: a }
|
||||||
|
deriving stock (Eq,Ord,Generic)
|
||||||
|
|
||||||
|
instance Pretty (AsBase58 a) => ToField (Base58Field a) where
|
||||||
|
toField (Base58Field x) = toField @String (show $ pretty (AsBase58 x))
|
||||||
|
|
||||||
|
instance IsString a => FromField (Base58Field a) where
|
||||||
|
fromField = fmap (Base58Field . fromString) . fromField @String
|
||||||
|
|
||||||
|
instance ToField HashRef where
|
||||||
|
toField h = toField @String (show $ pretty h)
|
||||||
|
|
||||||
|
instance FromField HashRef where
|
||||||
|
fromField = fmap fromString . fromField @String
|
||||||
|
|
||||||
|
instance ToField GitHash where
|
||||||
|
toField h = toField (show $ pretty h)
|
||||||
|
|
||||||
|
instance ToField GitRef where
|
||||||
|
toField h = toField (show $ pretty h)
|
||||||
|
|
||||||
|
instance FromField GitRef where
|
||||||
|
fromField = fmap fromString . fromField @String
|
||||||
|
|
||||||
|
instance FromField GitHash where
|
||||||
|
fromField = fmap fromString . fromField @String
|
||||||
|
|
||||||
|
|
||||||
|
createStateDir :: (GitPerks m, MonadReader GitEnv m) => m ()
|
||||||
|
createStateDir = do
|
||||||
|
void $ readConfig True
|
||||||
|
|
||||||
|
initState :: (GitPerks m, MonadReader GitEnv m) => m ()
|
||||||
|
initState = do
|
||||||
|
createStateDir
|
||||||
|
evolveDB
|
||||||
|
|
||||||
|
class WithState m a where
|
||||||
|
withState :: DBPipeM m a -> m a
|
||||||
|
|
||||||
|
instance (MonadIO m, MonadReader GitEnv m) => WithState m a where
|
||||||
|
withState action = do
|
||||||
|
env <- asks _db
|
||||||
|
withDB env action
|
||||||
|
|
||||||
|
|
||||||
|
evolveDB :: (GitPerks m, MonadReader GitEnv m) => m ()
|
||||||
|
evolveDB = withState do
|
||||||
|
createTxTable
|
||||||
|
createTxDoneTable
|
||||||
|
createTxBundleTable
|
||||||
|
createBundleDoneTable
|
||||||
|
createBundleKeyTable
|
||||||
|
createBundleObjectTable
|
||||||
|
createNewGK0Table
|
||||||
|
commitAll
|
||||||
|
|
||||||
|
createTxTable :: MonadIO m => DBPipeM m ()
|
||||||
|
createTxTable = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists tx
|
||||||
|
( reflog text not null
|
||||||
|
, tx text not null
|
||||||
|
, seq int not null
|
||||||
|
, head text not null
|
||||||
|
, bundle text not null
|
||||||
|
, primary key (reflog,tx)
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
ddl [qc|
|
||||||
|
CREATE INDEX IF NOT EXISTS idx_tx_seq ON tx(seq)
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
createTxDoneTable :: MonadIO m => DBPipeM m ()
|
||||||
|
createTxDoneTable = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists txdone
|
||||||
|
( tx text not null primary key
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
createBundleDoneTable :: MonadIO m => DBPipeM m ()
|
||||||
|
createBundleDoneTable = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists bundledone
|
||||||
|
( hash text primary key
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
createBundleKeyTable :: MonadIO m => DBPipeM m ()
|
||||||
|
|
||||||
|
createBundleKeyTable = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists bundlekey
|
||||||
|
( reflog text not null
|
||||||
|
, key text not null
|
||||||
|
, bundle text not null
|
||||||
|
, primary key (reflog, key)
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
createTxBundleTable :: MonadIO m => DBPipeM m ()
|
||||||
|
createTxBundleTable = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists txbundle
|
||||||
|
( tx text not null
|
||||||
|
, num integer not null
|
||||||
|
, bundle text not null
|
||||||
|
, primary key (tx, num)
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
createBundleObjectTable :: MonadIO m => DBPipeM m ()
|
||||||
|
createBundleObjectTable = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists bundleobject
|
||||||
|
( bundle text not null
|
||||||
|
, object text not null
|
||||||
|
, primary key (bundle, object)
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
createNewGK0Table :: MonadIO m => DBPipeM m ()
|
||||||
|
createNewGK0Table = do
|
||||||
|
ddl [qc|
|
||||||
|
create table if not exists newgk0
|
||||||
|
( reflog text not null
|
||||||
|
, tx text not null
|
||||||
|
, ts int not null default (strftime('%s','now'))
|
||||||
|
, gk0 text not null
|
||||||
|
, primary key (reflog,tx)
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
|
existsTx :: MonadIO m => HashRef -> DBPipeM m Bool
|
||||||
|
existsTx txHash = do
|
||||||
|
select @(Only Bool) [qc|
|
||||||
|
SELECT true FROM tx WHERE tx = ? LIMIT 1
|
||||||
|
|] (Only txHash)
|
||||||
|
<&> not . List.null
|
||||||
|
|
||||||
|
insertTx :: MonadIO m
|
||||||
|
=> RefLogId
|
||||||
|
-> HashRef
|
||||||
|
-> Integer
|
||||||
|
-> HashRef
|
||||||
|
-> HashRef
|
||||||
|
-> DBPipeM m ()
|
||||||
|
insertTx puk tx sn h bundle = do
|
||||||
|
insert [qc|
|
||||||
|
insert into tx (reflog,tx,seq,head,bundle)
|
||||||
|
values (?,?,?,?,?)
|
||||||
|
on conflict (reflog,tx) do nothing
|
||||||
|
|] (Base58Field puk,tx,sn,h,bundle)
|
||||||
|
|
||||||
|
|
||||||
|
selectTxForRefLog :: MonadIO m
|
||||||
|
=> RefLogId
|
||||||
|
-> HashRef
|
||||||
|
-> DBPipeM m (Maybe (HashRef, Epoch))
|
||||||
|
selectTxForRefLog puk tx = do
|
||||||
|
select [qc|
|
||||||
|
select head,seq
|
||||||
|
from tx where reflog = ? and tx = ?
|
||||||
|
limit 1
|
||||||
|
|] (Base58Field puk, tx) <&> listToMaybe
|
||||||
|
|
||||||
|
selectTxHead :: MonadIO m => HashRef -> DBPipeM m (Maybe HashRef)
|
||||||
|
selectTxHead txHash = do
|
||||||
|
result <- select [qc|
|
||||||
|
select head from tx where TX = ? limit 1
|
||||||
|
|] (Only txHash)
|
||||||
|
pure $ listToMaybe $ fmap fromOnly result
|
||||||
|
|
||||||
|
selectMaxTxSeq :: MonadIO m => RefLogId -> DBPipeM m Integer
|
||||||
|
selectMaxTxSeq puk = do
|
||||||
|
select [qc|
|
||||||
|
select max(seq) as seq from tx where reflog = ?
|
||||||
|
|] (Only (Base58Field puk))
|
||||||
|
<&> maybe 0 fromOnly . listToMaybe
|
||||||
|
|
||||||
|
insertTxDone :: MonadIO m => HashRef -> DBPipeM m ()
|
||||||
|
insertTxDone txHash = do
|
||||||
|
insert [qc|
|
||||||
|
INSERT INTO txdone (tx) VALUES (?)
|
||||||
|
ON CONFLICT (tx) DO NOTHING
|
||||||
|
|] (Only txHash)
|
||||||
|
|
||||||
|
|
||||||
|
existsTxDone :: MonadIO m => HashRef -> DBPipeM m Bool
|
||||||
|
existsTxDone txHash = do
|
||||||
|
select @(Only Bool) [qc|
|
||||||
|
SELECT true FROM txdone WHERE tx = ? LIMIT 1
|
||||||
|
|] (Only txHash)
|
||||||
|
<&> not . null
|
||||||
|
|
||||||
|
existsAnyTxDone :: MonadIO m => DBPipeM m Bool
|
||||||
|
existsAnyTxDone = do
|
||||||
|
select_ @_ @(Only (Maybe Bool)) [qc|
|
||||||
|
SELECT true FROM txdone LIMIT 1
|
||||||
|
|] <&> not . null
|
||||||
|
|
||||||
|
selectMaxSeqTxNotDone :: MonadIO m => RefLogId -> DBPipeM m (Maybe HashRef)
|
||||||
|
selectMaxSeqTxNotDone puk = do
|
||||||
|
select [qc|
|
||||||
|
WITH MaxDoneSeq AS (
|
||||||
|
SELECT MAX(tx.seq) as maxSeq
|
||||||
|
FROM tx
|
||||||
|
JOIN txdone ON tx.tx = txdone.tx
|
||||||
|
WHERE tx.reflog = ?
|
||||||
|
),
|
||||||
|
FilteredTx AS (
|
||||||
|
SELECT tx.tx, tx.seq
|
||||||
|
FROM tx
|
||||||
|
LEFT JOIN txdone ON tx.tx = txdone.tx
|
||||||
|
WHERE tx.reflog = ? AND txdone.tx IS NULL
|
||||||
|
)
|
||||||
|
SELECT ft.tx FROM FilteredTx ft
|
||||||
|
JOIN MaxDoneSeq mds ON ft.seq > COALESCE(mds.maxSeq, 0)
|
||||||
|
ORDER BY ft.seq DESC
|
||||||
|
LIMIT 1
|
||||||
|
|] (Base58Field puk, Base58Field puk)
|
||||||
|
<&> listToMaybe . fmap fromOnly
|
||||||
|
|
||||||
|
|
||||||
|
selectMaxAppliedTx :: MonadIO m => DBPipeM m (Maybe (HashRef, Integer))
|
||||||
|
selectMaxAppliedTx = do
|
||||||
|
select [qc|
|
||||||
|
SELECT t.tx, t.seq FROM txdone d JOIN tx t ON d.tx = t.tx ORDER BY t.seq DESC LIMIT 1
|
||||||
|
|] ()
|
||||||
|
<&> listToMaybe
|
||||||
|
|
||||||
|
insertBundleDone :: MonadIO m => HashRef -> DBPipeM m ()
|
||||||
|
insertBundleDone hashRef = do
|
||||||
|
insert [qc|
|
||||||
|
INSERT INTO bundledone (hash) VALUES (?)
|
||||||
|
ON CONFLICT (hash) DO NOTHING
|
||||||
|
|] (Only hashRef)
|
||||||
|
|
||||||
|
existsBundleDone :: MonadIO m => HashRef -> DBPipeM m Bool
|
||||||
|
existsBundleDone hashRef = do
|
||||||
|
select @(Only Bool) [qc|
|
||||||
|
SELECT true FROM bundledone WHERE hash = ? LIMIT 1
|
||||||
|
|] (Only hashRef)
|
||||||
|
<&> not . null
|
||||||
|
|
||||||
|
|
||||||
|
insertBundleKey :: MonadIO m => RefLogId -> HashRef -> HashRef -> DBPipeM m ()
|
||||||
|
insertBundleKey reflogId keyHash bundleHash = do
|
||||||
|
insert [qc|
|
||||||
|
INSERT INTO bundlekey (reflog, key, bundle) VALUES (?, ?, ?)
|
||||||
|
ON CONFLICT (reflog,key) DO NOTHING
|
||||||
|
|] (Base58Field reflogId, keyHash, bundleHash)
|
||||||
|
|
||||||
|
selectBundleByKey :: MonadIO m => RefLogId -> HashRef -> DBPipeM m (Maybe HashRef)
|
||||||
|
selectBundleByKey reflogId keyHash = do
|
||||||
|
select [qc|
|
||||||
|
SELECT bundle FROM bundlekey WHERE reflog = ? AND key = ? LIMIT 1
|
||||||
|
|] (Base58Field reflogId, keyHash)
|
||||||
|
<&> listToMaybe . fmap fromOnly
|
||||||
|
|
||||||
|
insertTxBundle :: MonadIO m => HashRef -> Int -> HashRef -> DBPipeM m ()
|
||||||
|
insertTxBundle tx num bundleHash = do
|
||||||
|
insert [qc|
|
||||||
|
INSERT INTO txbundle (tx, num, bundle) VALUES (?, ?, ?)
|
||||||
|
ON CONFLICT (tx, num) DO UPDATE SET bundle = EXCLUDED.bundle
|
||||||
|
|] (tx, num, bundleHash)
|
||||||
|
|
||||||
|
insertBundleObject :: MonadIO m => HashRef -> GitHash -> DBPipeM m ()
|
||||||
|
insertBundleObject bundle object = do
|
||||||
|
insert [qc|
|
||||||
|
insert into bundleobject (bundle, object) values (?, ?)
|
||||||
|
on conflict (bundle, object) do nothing
|
||||||
|
|] (bundle, object)
|
||||||
|
|
||||||
|
|
||||||
|
selectBundleObjects :: MonadIO m => HashRef -> DBPipeM m [GitHash]
|
||||||
|
selectBundleObjects bundle = do
|
||||||
|
select [qc|
|
||||||
|
select object from bundleobject where bundle = ?
|
||||||
|
|] (Only bundle)
|
||||||
|
<&> fmap fromOnly
|
||||||
|
|
||||||
|
|
||||||
|
selectObjectsForTx:: MonadIO m => HashRef -> DBPipeM m [GitHash]
|
||||||
|
selectObjectsForTx txHash = do
|
||||||
|
select [qc|
|
||||||
|
select distinct bundleobject.object
|
||||||
|
from txbundle
|
||||||
|
join bundleobject on txbundle.bundle = bundleobject.bundle
|
||||||
|
where txbundle.tx = ?
|
||||||
|
|] (Only txHash) <&> fmap fromOnly
|
||||||
|
|
||||||
|
|
||||||
|
isObjectInTx :: MonadIO m => HashRef -> GitHash -> DBPipeM m Bool
|
||||||
|
isObjectInTx txHash objectHash = do
|
||||||
|
result <- select @(Only Int) [qc|
|
||||||
|
select 1
|
||||||
|
from txbundle
|
||||||
|
join bundleobject on txbundle.bundle = bundleobject.bundle
|
||||||
|
where txbundle.tx = ? and bundleobject.object = ?
|
||||||
|
limit 1
|
||||||
|
|] (txHash, objectHash)
|
||||||
|
pure $ not (null result)
|
||||||
|
|
||||||
|
|
||||||
|
insertNewGK0 :: MonadIO m => RefLogId -> HashRef -> HashRef -> DBPipeM m ()
|
||||||
|
insertNewGK0 reflog tx gk0 = do
|
||||||
|
insert [qc|
|
||||||
|
insert into newgk0 (reflog, tx, gk0) values (?, ?, ?)
|
||||||
|
on conflict (reflog,tx) do update set gk0 = excluded.gk0
|
||||||
|
|] (Base58Field reflog, tx, gk0)
|
||||||
|
|
||||||
|
selectNewGK0 :: MonadIO m => RefLogId -> DBPipeM m (Maybe (HashRef,Epoch))
|
||||||
|
selectNewGK0 reflog = do
|
||||||
|
select [qc|
|
||||||
|
select gk0, ts
|
||||||
|
from newgk0 g
|
||||||
|
where g.reflog = ?
|
||||||
|
order by ts desc
|
||||||
|
limit 1
|
||||||
|
|] (Only (Base58Field reflog)) <&> listToMaybe
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,26 @@
|
||||||
|
module HBS2.Git.Data.GK where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
|
||||||
|
import HBS2.Net.Auth.GroupKeySymm
|
||||||
|
import HBS2.Storage.Operations.ByteString
|
||||||
|
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
|
||||||
|
type GK0 = GroupKey 'Symm HBS2Basic
|
||||||
|
|
||||||
|
readGK0 :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m GK0
|
||||||
|
readGK0 sto h = do
|
||||||
|
runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h)))
|
||||||
|
>>= orThrowError MissedBlockError
|
||||||
|
<&> deserialiseOrFail @GK0
|
||||||
|
>>= orThrowError UnsupportedFormat
|
||||||
|
|
||||||
|
loadGK0FromFile :: MonadIO m => FilePath -> m (Maybe GK0)
|
||||||
|
loadGK0FromFile fp = runMaybeT do
|
||||||
|
|
||||||
|
content <- liftIO (try @_ @IOError (LBS.readFile fp))
|
||||||
|
>>= toMPlus
|
||||||
|
|
||||||
|
toMPlus $ parseGroupKey @HBS2Basic (AsGroupKeyFile content)
|
||||||
|
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
module HBS2.Git.Data.RefLog where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
|
||||||
|
type RefLogId = PubKey 'Sign HBS2Basic
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,383 @@
|
||||||
|
module HBS2.Git.Data.Tx
|
||||||
|
( module HBS2.Git.Data.Tx
|
||||||
|
, OperationError(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import HBS2.Git.Client.Prelude
|
||||||
|
import HBS2.Git.Data.RefLog
|
||||||
|
|
||||||
|
import HBS2.Defaults
|
||||||
|
import HBS2.Data.Detect
|
||||||
|
import HBS2.KeyMan.Keys.Direct
|
||||||
|
import HBS2.Peer.Proto
|
||||||
|
import HBS2.Net.Auth.GroupKeySymm
|
||||||
|
import HBS2.Net.Auth.Credentials
|
||||||
|
import HBS2.Storage.Operations.ByteString
|
||||||
|
import HBS2.Storage.Operations.Missed
|
||||||
|
|
||||||
|
import HBS2.Git.Data.GK
|
||||||
|
|
||||||
|
import HBS2.Git.Local
|
||||||
|
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Either
|
||||||
|
import Data.Word
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
import Data.Binary.Get
|
||||||
|
import Data.ByteArray.Hash (SipHash(..), SipKey(..))
|
||||||
|
import Data.ByteArray.Hash qualified as BA
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
|
||||||
|
type Rank = Integer
|
||||||
|
|
||||||
|
|
||||||
|
type LBS = LBS.ByteString
|
||||||
|
|
||||||
|
type RepoTx = RefLogUpdate L4Proto
|
||||||
|
|
||||||
|
data RepoHeadType = RepoHeadType1
|
||||||
|
deriving stock (Enum,Generic)
|
||||||
|
|
||||||
|
data RepoHeadExt = RepoHeadExt
|
||||||
|
deriving stock Generic
|
||||||
|
|
||||||
|
data RepoHead =
|
||||||
|
RepoHeadSimple
|
||||||
|
{ _repoHeadType :: RepoHeadType
|
||||||
|
, _repoHeadTime :: Word64
|
||||||
|
, _repoHeadGK0 :: Maybe HashRef
|
||||||
|
, _repoHeadName :: Text
|
||||||
|
, _repoHeadBrief :: Text
|
||||||
|
, _repoManifest :: Maybe Text
|
||||||
|
, _repoHeadRefs :: [(GitRef, GitHash)]
|
||||||
|
, _repoHeadExt :: [RepoHeadExt]
|
||||||
|
}
|
||||||
|
deriving stock (Generic)
|
||||||
|
|
||||||
|
|
||||||
|
instance Serialise RepoHeadType
|
||||||
|
instance Serialise RepoHeadExt
|
||||||
|
instance Serialise RepoHead
|
||||||
|
|
||||||
|
data TxKeyringNotFound = TxKeyringNotFound
|
||||||
|
deriving stock (Show, Typeable, Generic)
|
||||||
|
|
||||||
|
instance Exception TxKeyringNotFound
|
||||||
|
|
||||||
|
class GroupKeyOperations m where
|
||||||
|
openGroupKey :: GK0 -> m (Maybe GroupSecret)
|
||||||
|
loadKeyrings :: HashRef -> m [KeyringEntry HBS2Basic]
|
||||||
|
|
||||||
|
makeRepoHeadSimple :: MonadIO m
|
||||||
|
=> Text
|
||||||
|
-> Text
|
||||||
|
-> Maybe Text
|
||||||
|
-> Maybe HashRef
|
||||||
|
-> [(GitRef, GitHash)]
|
||||||
|
-> m RepoHead
|
||||||
|
makeRepoHeadSimple name brief manifest gk refs = do
|
||||||
|
t <- getEpoch
|
||||||
|
pure $ RepoHeadSimple RepoHeadType1 t gk name brief manifest refs mempty
|
||||||
|
|
||||||
|
writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef
|
||||||
|
writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef
|
||||||
|
|
||||||
|
makeTx :: (MonadUnliftIO m, GroupKeyOperations m)
|
||||||
|
=> AnyStorage
|
||||||
|
-> Bool -- ^ rewrite bundle merkle tree with new gk0
|
||||||
|
-> Rank -- ^ tx rank
|
||||||
|
-> RefLogId
|
||||||
|
-> RepoHead
|
||||||
|
-> [HashRef]
|
||||||
|
-> [LBS]
|
||||||
|
-> m RepoTx
|
||||||
|
|
||||||
|
makeTx sto rewrite r puk rh prev lbss = do
|
||||||
|
|
||||||
|
let rfk = RefLogKey @HBS2Basic puk
|
||||||
|
|
||||||
|
creds <- liftIO ( runKeymanClient $ loadCredentials puk )
|
||||||
|
>>= orThrow TxKeyringNotFound
|
||||||
|
|
||||||
|
let pubk = view peerSignPk creds
|
||||||
|
let privk = view peerSignSk creds
|
||||||
|
|
||||||
|
-- FIXME: delete-on-fail
|
||||||
|
headRef <- writeRepoHead sto rh
|
||||||
|
|
||||||
|
writeEnv <- newWriteBundleEnv sto rh
|
||||||
|
|
||||||
|
cRefs <- for lbss (writeBundle writeEnv)
|
||||||
|
|
||||||
|
let newBundles0 = prev <> cRefs
|
||||||
|
|
||||||
|
newBundles <- do
|
||||||
|
if not rewrite then do
|
||||||
|
pure newBundles0
|
||||||
|
else do
|
||||||
|
for newBundles0 \bh -> do
|
||||||
|
|
||||||
|
blk <- getBlock sto (fromHashRef bh)
|
||||||
|
>>= orThrow StorageError
|
||||||
|
|
||||||
|
case tryDetect (fromHashRef bh) blk of
|
||||||
|
|
||||||
|
Merkle{} -> do
|
||||||
|
bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef bh)))
|
||||||
|
>>= either throwIO pure
|
||||||
|
|
||||||
|
trace $ "encrypt existed block" <+> pretty bh
|
||||||
|
writeBundle writeEnv bs
|
||||||
|
|
||||||
|
MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm2 o gkh nonce}) -> do
|
||||||
|
|
||||||
|
gk <- runExceptT (readGK0 sto (HashRef gkh))
|
||||||
|
>>= orThrow (GroupKeyNotFound 4)
|
||||||
|
|
||||||
|
gks <- openGroupKey gk
|
||||||
|
>>= orThrow (GroupKeyNotFound 5)
|
||||||
|
|
||||||
|
debug $ "update GK0 for existed block" <+> pretty bh
|
||||||
|
let rcpt = HM.keys (recipients (wbeGk0 writeEnv))
|
||||||
|
gk1 <- generateGroupKey @HBS2Basic (Just gks) rcpt
|
||||||
|
|
||||||
|
gk1h <- writeAsMerkle sto (serialise gk1)
|
||||||
|
|
||||||
|
let newCrypt = EncryptGroupNaClSymm2 o gk1h nonce
|
||||||
|
let newTreeBlock = ann { _mtaCrypt = newCrypt }
|
||||||
|
|
||||||
|
newTree <- enqueueBlock sto (serialise newTreeBlock)
|
||||||
|
>>= orThrow StorageError
|
||||||
|
|
||||||
|
pure (HashRef newTree)
|
||||||
|
|
||||||
|
_ -> throwIO UnsupportedFormat
|
||||||
|
|
||||||
|
let pt = toPTree (MaxSize defHashListChunk) (MaxNum 256) newBundles
|
||||||
|
|
||||||
|
me <- makeMerkle 0 pt $ \(_,_,bss) -> do
|
||||||
|
void $ putBlock sto bss
|
||||||
|
|
||||||
|
let meRef = HashRef me
|
||||||
|
|
||||||
|
-- TODO: post-real-rank-for-tx
|
||||||
|
let tx = SequentialRef r (AnnotatedHashRef (Just headRef) meRef)
|
||||||
|
& serialise
|
||||||
|
& LBS.toStrict
|
||||||
|
|
||||||
|
makeRefLogUpdate @L4Proto @HBS2Basic pubk privk tx
|
||||||
|
|
||||||
|
|
||||||
|
unpackTx :: MonadIO m
|
||||||
|
=> RefLogUpdate L4Proto
|
||||||
|
-> m (Integer, HashRef, HashRef)
|
||||||
|
|
||||||
|
unpackTx tx = do
|
||||||
|
|
||||||
|
sr <- deserialiseOrFail @SequentialRef (LBS.fromStrict (view refLogUpdData tx))
|
||||||
|
& orThrow UnsupportedFormat
|
||||||
|
|
||||||
|
case sr of
|
||||||
|
SequentialRef n (AnnotatedHashRef (Just rhh) blkh) -> pure (n,rhh,blkh)
|
||||||
|
_ -> throwIO UnsupportedFormat
|
||||||
|
|
||||||
|
readTx :: (MonadIO m, MonadError OperationError m)
|
||||||
|
=> AnyStorage
|
||||||
|
-> HashRef
|
||||||
|
-> m (Integer, HashRef, RepoHead, HashRef)
|
||||||
|
|
||||||
|
readTx sto href = do
|
||||||
|
|
||||||
|
tx <- getBlock sto (fromHashRef href)
|
||||||
|
>>= orThrowError MissedBlockError
|
||||||
|
<&> deserialiseOrFail @(RefLogUpdate L4Proto)
|
||||||
|
>>= orThrowError UnsupportedFormat
|
||||||
|
|
||||||
|
(n,rhh,blkh) <- unpackTx tx
|
||||||
|
|
||||||
|
rh <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rhh)))
|
||||||
|
>>= orThrowError IncompleteData
|
||||||
|
<&> deserialiseOrFail @RepoHead
|
||||||
|
>>= orThrowError UnsupportedFormat
|
||||||
|
|
||||||
|
missed <- S.head_ (findMissedBlocks2 sto blkh) <&> isJust
|
||||||
|
|
||||||
|
when missed do
|
||||||
|
throwError IncompleteData
|
||||||
|
|
||||||
|
pure (n, rhh, rh, blkh)
|
||||||
|
|
||||||
|
|
||||||
|
readRepoHeadFromTx :: MonadIO m
|
||||||
|
=> AnyStorage
|
||||||
|
-> HashRef
|
||||||
|
-> m (Maybe RepoHead)
|
||||||
|
|
||||||
|
readRepoHeadFromTx sto href = runMaybeT do
|
||||||
|
|
||||||
|
tx <- getBlock sto (fromHashRef href) >>= toMPlus
|
||||||
|
<&> deserialiseOrFail @(RefLogUpdate L4Proto)
|
||||||
|
>>= toMPlus
|
||||||
|
|
||||||
|
(n,rhh,_) <- unpackTx tx
|
||||||
|
|
||||||
|
runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rhh)))
|
||||||
|
>>= toMPlus
|
||||||
|
<&> deserialiseOrFail @RepoHead
|
||||||
|
>>= toMPlus
|
||||||
|
|
||||||
|
|
||||||
|
data BundleMeta =
|
||||||
|
BundleMeta
|
||||||
|
{ bundleHash :: HashRef
|
||||||
|
, bundleEncrypted :: Bool
|
||||||
|
}
|
||||||
|
deriving stock (Show,Generic)
|
||||||
|
|
||||||
|
data BundleWithMeta =
|
||||||
|
BundleWithMeta
|
||||||
|
{ bundleMeta :: BundleMeta
|
||||||
|
, bundlebBytes :: LBS
|
||||||
|
}
|
||||||
|
deriving stock (Generic)
|
||||||
|
|
||||||
|
readBundle :: (MonadIO m, MonadError OperationError m, GroupKeyOperations m)
|
||||||
|
=> AnyStorage
|
||||||
|
-> RepoHead
|
||||||
|
-> HashRef
|
||||||
|
-> m BundleWithMeta
|
||||||
|
readBundle sto rh ref = do
|
||||||
|
|
||||||
|
obj <- getBlock sto (fromHashRef ref)
|
||||||
|
>>= orThrow MissedBlockError
|
||||||
|
|
||||||
|
let q = tryDetect (fromHashRef ref) obj
|
||||||
|
|
||||||
|
case q of
|
||||||
|
Merkle t -> do
|
||||||
|
let meta = BundleMeta ref False
|
||||||
|
BundleWithMeta meta <$>
|
||||||
|
readFromMerkle sto (SimpleKey key)
|
||||||
|
|
||||||
|
MerkleAnn (MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
|
||||||
|
ke <- loadKeyrings (HashRef gkh)
|
||||||
|
let meta = BundleMeta ref True
|
||||||
|
BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS ke key)
|
||||||
|
|
||||||
|
_ -> throwError UnsupportedFormat
|
||||||
|
|
||||||
|
where
|
||||||
|
key = fromHashRef ref
|
||||||
|
|
||||||
|
readBundleRefs :: (MonadIO m)
|
||||||
|
=> AnyStorage
|
||||||
|
-> HashRef
|
||||||
|
-> m (Either [HashRef] [HashRef])
|
||||||
|
|
||||||
|
readBundleRefs sto bunh = do
|
||||||
|
r <- S.toList_ $
|
||||||
|
walkMerkle @[HashRef] (fromHashRef bunh) (getBlock sto) $ \case
|
||||||
|
Left h -> S.yield (Left h)
|
||||||
|
Right ( bundles :: [HashRef] ) -> do
|
||||||
|
mapM_ (S.yield . Right) bundles
|
||||||
|
|
||||||
|
let missed = lefts r
|
||||||
|
|
||||||
|
if not (null missed) then do
|
||||||
|
pure (Left (fmap HashRef missed))
|
||||||
|
else do
|
||||||
|
pure (Right $ rights r)
|
||||||
|
|
||||||
|
|
||||||
|
type GitPack = LBS.ByteString
|
||||||
|
type UnpackedBundle = (Word32, Word32, [GitHash], GitPack)
|
||||||
|
|
||||||
|
unpackPackMay :: LBS.ByteString -> Maybe UnpackedBundle
|
||||||
|
unpackPackMay co = result $ flip runGetOrFail co do
|
||||||
|
w <- getWord32be
|
||||||
|
v <- getWord32be
|
||||||
|
idx <- lookAheadE (getLazyByteString (fromIntegral w) <&> deserialiseOrFail @[GitHash])
|
||||||
|
>>= either (fail.show) pure
|
||||||
|
pack <- getRemainingLazyByteString
|
||||||
|
pure (w,v,idx,pack)
|
||||||
|
|
||||||
|
where
|
||||||
|
result = \case
|
||||||
|
Left{} -> Nothing
|
||||||
|
Right (_,_,r) -> Just r
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
data WriteBundleEnv =
|
||||||
|
WriteBundleEnvPlain
|
||||||
|
{ wbeHead :: RepoHead
|
||||||
|
, wbeStorage :: AnyStorage
|
||||||
|
}
|
||||||
|
| WriteBundleEnvEnc
|
||||||
|
{ wbeSk1 :: SipKey
|
||||||
|
, wbeSk2 :: SipKey
|
||||||
|
, wbeHead :: RepoHead
|
||||||
|
, wbeGk0 :: GK0
|
||||||
|
, wbeGks :: GroupSecret
|
||||||
|
, wbeStorage :: AnyStorage
|
||||||
|
}
|
||||||
|
|
||||||
|
newWriteBundleEnv :: (MonadIO m, GroupKeyOperations m) => AnyStorage -> RepoHead -> m WriteBundleEnv
|
||||||
|
newWriteBundleEnv sto rh = case _repoHeadGK0 rh of
|
||||||
|
Nothing -> do
|
||||||
|
pure $ WriteBundleEnvPlain rh sto
|
||||||
|
|
||||||
|
Just gk0h -> do
|
||||||
|
|
||||||
|
gk0 <- runExceptT (readGK0 sto gk0h)
|
||||||
|
>>= either throwIO pure
|
||||||
|
|
||||||
|
gks <- openGroupKey gk0
|
||||||
|
>>= orThrow (GroupKeyNotFound 3)
|
||||||
|
|
||||||
|
pure $ WriteBundleEnvEnc
|
||||||
|
{ wbeSk1 = SipKey 2716370006254639645 507093936407764973
|
||||||
|
, wbeSk2 = SipKey 9209704780415729085 272090086441077315
|
||||||
|
, wbeHead = rh
|
||||||
|
, wbeGk0 = gk0
|
||||||
|
, wbeGks = gks
|
||||||
|
, wbeStorage = sto
|
||||||
|
}
|
||||||
|
|
||||||
|
makeNonceForBundle :: Monad m => WriteBundleEnv -> LBS.ByteString -> m ByteString
|
||||||
|
makeNonceForBundle env lbs = do
|
||||||
|
let piece = ( LBS.take (fromIntegral defBlockSize * 2) lbs
|
||||||
|
<> serialise (wbeHead env)
|
||||||
|
) & hashObject @HbSync & serialise & LBS.drop 1 & LBS.toStrict
|
||||||
|
pure piece
|
||||||
|
|
||||||
|
writeBundle :: MonadIO m => WriteBundleEnv -> LBS.ByteString -> m HashRef
|
||||||
|
writeBundle env lbs = do
|
||||||
|
|
||||||
|
case env of
|
||||||
|
WriteBundleEnvPlain{..} -> do
|
||||||
|
writeAsMerkle wbeStorage lbs <&> HashRef
|
||||||
|
|
||||||
|
WriteBundleEnvEnc{..} -> do
|
||||||
|
let bsStream = readChunkedBS lbs defBlockSize
|
||||||
|
|
||||||
|
nonce <- makeNonceForBundle env lbs
|
||||||
|
|
||||||
|
let (SipHash a) = BA.sipHash wbeSk1 nonce
|
||||||
|
let (SipHash b) = BA.sipHash wbeSk2 nonce
|
||||||
|
|
||||||
|
let source = ToEncryptSymmBS wbeGks
|
||||||
|
(Right wbeGk0)
|
||||||
|
nonce
|
||||||
|
bsStream
|
||||||
|
NoMetaData
|
||||||
|
(Just (EncryptGroupNaClSymmBlockSIP (a,b)))
|
||||||
|
|
||||||
|
th <- runExceptT (writeAsMerkle wbeStorage source)
|
||||||
|
>>= orThrow StorageError
|
||||||
|
|
||||||
|
pure $ HashRef th
|
||||||
|
|
||||||
|
|
@ -0,0 +1,68 @@
|
||||||
|
module HBS2.Git.Local where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
|
||||||
|
import Data.ByteString.Base16 qualified as B16
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
import Data.ByteString.Char8 qualified as BS
|
||||||
|
import Data.ByteString.Char8 (ByteString)
|
||||||
|
import Codec.Serialise
|
||||||
|
|
||||||
|
|
||||||
|
data SHA1 = SHA1
|
||||||
|
deriving stock(Eq,Ord,Data,Generic)
|
||||||
|
|
||||||
|
newtype GitHash = GitHash ByteString
|
||||||
|
deriving stock (Eq,Ord,Data,Generic,Show)
|
||||||
|
deriving newtype Hashable
|
||||||
|
|
||||||
|
instance Serialise GitHash
|
||||||
|
|
||||||
|
instance IsString GitHash where
|
||||||
|
fromString s = GitHash (B16.decodeLenient (BS.pack s))
|
||||||
|
|
||||||
|
instance FromStringMaybe GitHash where
|
||||||
|
fromStringMay s = either (const Nothing) (pure . GitHash) (B16.decode bs)
|
||||||
|
where
|
||||||
|
bs = BS.pack s
|
||||||
|
|
||||||
|
instance Pretty GitHash where
|
||||||
|
pretty (GitHash s) = pretty @String [qc|{B16.encode s}|]
|
||||||
|
|
||||||
|
|
||||||
|
newtype GitRef = GitRef { unGitRef :: ByteString }
|
||||||
|
deriving stock (Eq,Ord,Data,Generic,Show)
|
||||||
|
deriving newtype (IsString,Monoid,Semigroup,Hashable)
|
||||||
|
|
||||||
|
instance Serialise GitRef
|
||||||
|
|
||||||
|
mkGitRef :: ByteString -> GitRef
|
||||||
|
mkGitRef = GitRef
|
||||||
|
|
||||||
|
instance Pretty GitRef where
|
||||||
|
pretty (GitRef x) = pretty @String [qc|{x}|]
|
||||||
|
|
||||||
|
data GitObjectType = Commit | Tree | Blob
|
||||||
|
deriving stock (Eq,Ord,Show,Generic)
|
||||||
|
|
||||||
|
instance Serialise GitObjectType
|
||||||
|
|
||||||
|
instance IsString GitObjectType where
|
||||||
|
fromString = \case
|
||||||
|
"commit" -> Commit
|
||||||
|
"tree" -> Tree
|
||||||
|
"blob" -> Blob
|
||||||
|
x -> error [qc|invalid git object type {x}|]
|
||||||
|
|
||||||
|
instance FromStringMaybe GitObjectType where
|
||||||
|
fromStringMay = \case
|
||||||
|
"commit" -> Just Commit
|
||||||
|
"tree" -> Just Tree
|
||||||
|
"blob" -> Just Blob
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
instance Pretty GitObjectType where
|
||||||
|
pretty = \case
|
||||||
|
Commit -> pretty @String "commit"
|
||||||
|
Tree -> pretty @String "tree"
|
||||||
|
Blob -> pretty @String "blob"
|
||||||
|
|
@ -0,0 +1,66 @@
|
||||||
|
module HBS2.Git.Local.CLI where
|
||||||
|
|
||||||
|
import HBS2.Prelude
|
||||||
|
|
||||||
|
import System.FilePath
|
||||||
|
import HBS2.System.Dir
|
||||||
|
|
||||||
|
import System.Environment hiding (setEnv)
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Control.Applicative
|
||||||
|
import System.Process.Typed
|
||||||
|
import Data.ByteString.Lazy (ByteString)
|
||||||
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
findGitDir :: MonadIO m => m (Maybe FilePath)
|
||||||
|
findGitDir = findGitDir' =<< pwd
|
||||||
|
where
|
||||||
|
findGitDir' dir = do
|
||||||
|
let gd = dir </> ".git"
|
||||||
|
exists <- liftIO $ doesDirectoryExist gd
|
||||||
|
if exists
|
||||||
|
then return $ Just gd
|
||||||
|
else let parentDir = takeDirectory dir
|
||||||
|
in if parentDir == dir -- we've reached the root directory
|
||||||
|
then return Nothing
|
||||||
|
else findGitDir' parentDir
|
||||||
|
|
||||||
|
checkIsBare :: MonadIO m => Maybe FilePath -> m Bool
|
||||||
|
checkIsBare fp = do
|
||||||
|
|
||||||
|
let wd = maybe id setWorkingDir fp
|
||||||
|
|
||||||
|
(code,s,_) <- readProcess ( shell [qc|git config --local core.bare|]
|
||||||
|
& setStderr closed & wd
|
||||||
|
)
|
||||||
|
|
||||||
|
case (code, LBS8.words s) of
|
||||||
|
(ExitSuccess, "true" : _) -> pure True
|
||||||
|
_ -> pure False
|
||||||
|
|
||||||
|
gitDir :: MonadIO m => m (Maybe FilePath)
|
||||||
|
gitDir = runMaybeT do
|
||||||
|
byEnv <- liftIO $ lookupEnv "GIT_DIR"
|
||||||
|
byDir <- findGitDir
|
||||||
|
|
||||||
|
byBare <- checkIsBare Nothing >>= \case
|
||||||
|
True -> pwd >>= expandPath <&> Just
|
||||||
|
False -> pure Nothing
|
||||||
|
|
||||||
|
toMPlus (byEnv <|> byDir <|> byBare)
|
||||||
|
|
||||||
|
|
||||||
|
gitRunCommand :: MonadIO m
|
||||||
|
=> String
|
||||||
|
-> m (Either ExitCode ByteString)
|
||||||
|
|
||||||
|
gitRunCommand cmd = do
|
||||||
|
let procCfg = setStdin closed $ setStderr closed $ shell cmd
|
||||||
|
(code, out, _) <- readProcess procCfg
|
||||||
|
case code of
|
||||||
|
ExitSuccess -> pure (Right out)
|
||||||
|
e -> pure (Left e)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,155 @@
|
||||||
|
cabal-version: 3.0
|
||||||
|
name: hbs21-git
|
||||||
|
version: 0.1.0.0
|
||||||
|
-- synopsis:
|
||||||
|
-- description:
|
||||||
|
license: BSD-3-Clause
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Dmitry Zuikov
|
||||||
|
maintainer: dzuikov@gmail.com
|
||||||
|
-- copyright:
|
||||||
|
category: System
|
||||||
|
build-type: Simple
|
||||||
|
-- extra-doc-files: CHANGELOG.md
|
||||||
|
-- extra-source-files:
|
||||||
|
|
||||||
|
common shared-properties
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-fno-warn-type-defaults
|
||||||
|
-threaded
|
||||||
|
-rtsopts
|
||||||
|
-O2
|
||||||
|
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||||
|
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
, BangPatterns
|
||||||
|
, BlockArguments
|
||||||
|
, ConstraintKinds
|
||||||
|
, DataKinds
|
||||||
|
, DeriveDataTypeable
|
||||||
|
, DeriveGeneric
|
||||||
|
, DerivingStrategies
|
||||||
|
, DerivingVia
|
||||||
|
, ExtendedDefaultRules
|
||||||
|
, FlexibleContexts
|
||||||
|
, FlexibleInstances
|
||||||
|
, GADTs
|
||||||
|
, GeneralizedNewtypeDeriving
|
||||||
|
, ImportQualifiedPost
|
||||||
|
, LambdaCase
|
||||||
|
, MultiParamTypeClasses
|
||||||
|
, OverloadedStrings
|
||||||
|
, QuasiQuotes
|
||||||
|
, RecordWildCards
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, StandaloneDeriving
|
||||||
|
, TupleSections
|
||||||
|
, TypeApplications
|
||||||
|
, TypeFamilies
|
||||||
|
|
||||||
|
|
||||||
|
build-depends:
|
||||||
|
hbs2-core
|
||||||
|
, hbs2-peer
|
||||||
|
, hbs2-storage-simple
|
||||||
|
, hbs2-keyman
|
||||||
|
, db-pipe
|
||||||
|
, suckless-conf
|
||||||
|
|
||||||
|
, attoparsec
|
||||||
|
, atomic-write
|
||||||
|
, bytestring
|
||||||
|
, binary
|
||||||
|
, containers
|
||||||
|
, directory
|
||||||
|
, exceptions
|
||||||
|
, filepath
|
||||||
|
, filepattern
|
||||||
|
, interpolatedstring-perl6
|
||||||
|
, memory
|
||||||
|
, microlens-platform
|
||||||
|
, mtl
|
||||||
|
, safe
|
||||||
|
, serialise
|
||||||
|
, streaming
|
||||||
|
, stm
|
||||||
|
, text
|
||||||
|
, time
|
||||||
|
, timeit
|
||||||
|
, transformers
|
||||||
|
, typed-process
|
||||||
|
, unordered-containers
|
||||||
|
, unliftio
|
||||||
|
, unliftio-core
|
||||||
|
, zlib
|
||||||
|
, prettyprinter
|
||||||
|
, prettyprinter-ansi-terminal
|
||||||
|
, random
|
||||||
|
, vector
|
||||||
|
, unix
|
||||||
|
|
||||||
|
|
||||||
|
library hbs2-git-client-lib
|
||||||
|
import: shared-properties
|
||||||
|
|
||||||
|
exposed-modules:
|
||||||
|
HBS2.Git.Local
|
||||||
|
HBS2.Git.Local.CLI
|
||||||
|
|
||||||
|
HBS2.Git.Data.Tx
|
||||||
|
HBS2.Git.Data.GK
|
||||||
|
HBS2.Git.Data.RefLog
|
||||||
|
|
||||||
|
HBS2.Git.Client.Prelude
|
||||||
|
HBS2.Git.Client.App.Types
|
||||||
|
HBS2.Git.Client.App.Types.GitEnv
|
||||||
|
HBS2.Git.Client.App
|
||||||
|
HBS2.Git.Client.Config
|
||||||
|
HBS2.Git.Client.State
|
||||||
|
HBS2.Git.Client.RefLog
|
||||||
|
HBS2.Git.Client.Export
|
||||||
|
HBS2.Git.Client.Import
|
||||||
|
HBS2.Git.Client.Progress
|
||||||
|
|
||||||
|
build-depends: base
|
||||||
|
, base16-bytestring
|
||||||
|
, binary
|
||||||
|
, unix
|
||||||
|
|
||||||
|
hs-source-dirs: hbs2-git-client-lib
|
||||||
|
|
||||||
|
|
||||||
|
executable git-hbs21
|
||||||
|
import: shared-properties
|
||||||
|
main-is: Main.hs
|
||||||
|
-- other-modules:
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends:
|
||||||
|
base, hbs2-git-client-lib
|
||||||
|
, binary
|
||||||
|
, vector
|
||||||
|
, optparse-applicative
|
||||||
|
|
||||||
|
hs-source-dirs: git-hbs21
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|
||||||
|
executable git-remote-hbs21
|
||||||
|
import: shared-properties
|
||||||
|
main-is: Main.hs
|
||||||
|
-- other-modules:
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends:
|
||||||
|
base, hbs2-git-client-lib
|
||||||
|
, binary
|
||||||
|
, vector
|
||||||
|
, optparse-applicative
|
||||||
|
|
||||||
|
hs-source-dirs: git-remote-hbs21
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue