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 \
|
||||
git-remote-hbs2 \
|
||||
git-hbs2 \
|
||||
git-remote-hbs21 \
|
||||
git-hbs21 \
|
||||
|
||||
ifeq ($(origin .RECIPEPREFIX), undefined)
|
||||
$(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-keyman"
|
||||
"hbs2-share"
|
||||
"hbs21-git"
|
||||
];
|
||||
in
|
||||
haskell-flake-utils.lib.simpleCabalProject2flake {
|
||||
|
|
@ -60,6 +61,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
|||
"hbs2-keyman" = "./hbs2-keyman";
|
||||
"hbs2-share" = "./hbs2-share";
|
||||
"hbs2-git" = "./hbs2-git";
|
||||
"hbs21-git" = "./hbs21-git";
|
||||
"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