mirror of https://github.com/voidlizard/hbs2
Drop hbs2-git, Move needed modules to hbs2-git3
This commit is contained in:
Snail
parent
1cf7ec6cbc
commit
59c27c5d5d
|
|
@ -56,7 +56,7 @@ common shared-properties
|
|||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman-direct-lib
|
||||
, hbs2-git
|
||||
, hbs2-git3
|
||||
, hbs2-cli
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
|
@ -135,7 +135,7 @@ executable fixme-new
|
|||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, fixme-new, hbs2-core, hbs2-peer, hbs2-git
|
||||
base, fixme-new, hbs2-core, hbs2-peer
|
||||
, binary
|
||||
, vector
|
||||
, optparse-applicative
|
||||
|
|
|
|||
|
|
@ -33,7 +33,6 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
|||
"hbs2-peer"
|
||||
"hbs2-core"
|
||||
"hbs2-storage-simple"
|
||||
"hbs2-git"
|
||||
"hbs2-git3"
|
||||
"hbs2-cli"
|
||||
"hbs2-sync"
|
||||
|
|
|
|||
|
|
@ -1,111 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Git.Client.Prelude hiding (info)
|
||||
import HBS2.Git.Client.App hiding (_progress, _storage, _peerAPI, _lwwAPI, _refLogAPI)
|
||||
import HBS2.Git.Client.Progress
|
||||
import HBS2.Git.Client.Import
|
||||
import HBS2.Git.Client.RefLog
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
||||
import Options.Applicative
|
||||
import Data.Semigroup ((<>))
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let parser = subscribe
|
||||
<$> optional (strOption
|
||||
( long "socket"
|
||||
<> short 's'
|
||||
<> metavar "SOCKET"
|
||||
<> help "Socket file path"))
|
||||
<*> argument pLww (metavar "LWWREF")
|
||||
join $ execParser (info (parser <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "Parse command line arguments"
|
||||
<> header "Command line arguments parsing example"))
|
||||
|
||||
|
||||
where
|
||||
pLww :: ReadM (LWWRefKey 'HBS2Basic)
|
||||
pLww = maybeReader fromStringMay
|
||||
|
||||
|
||||
data MyStuff =
|
||||
MyStuff
|
||||
{ _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _lwwAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _storage :: AnyStorage
|
||||
, _progress :: AnyProgress
|
||||
}
|
||||
|
||||
newtype MyApp m a = MyApp { fromMyApp :: ReaderT MyStuff m a }
|
||||
deriving newtype ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadThrow
|
||||
, MonadReader MyStuff
|
||||
)
|
||||
|
||||
instance Monad m => HasProgressIndicator (MyApp m) where
|
||||
getProgressIndicator = asks _progress
|
||||
|
||||
instance Monad m => HasStorage (MyApp m) where
|
||||
getStorage = asks _storage
|
||||
|
||||
instance Monad m => HasAPI PeerAPI UNIX (MyApp m) where
|
||||
getAPI = asks _peerAPI
|
||||
|
||||
instance Monad m => HasAPI LWWRefAPI UNIX (MyApp m) where
|
||||
getAPI = asks _lwwAPI
|
||||
|
||||
instance Monad m => HasAPI RefLogAPI UNIX (MyApp m) where
|
||||
getAPI = asks _refLogAPI
|
||||
|
||||
subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey 'HBS2Basic -> m ()
|
||||
subscribe soname' ref = do
|
||||
|
||||
soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc"
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
||||
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
||||
|
||||
q <- lift newProgressQ
|
||||
let ip = AnyProgress q
|
||||
|
||||
void $ ContT $ withAsync $ runMessagingUnix client
|
||||
void $ ContT $ withAsync $ drawProgress q
|
||||
|
||||
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||||
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
||||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
||||
|
||||
let sto = AnyStorage (StorageClient storageAPI)
|
||||
|
||||
let endpoints = [ Endpoint @UNIX peerAPI
|
||||
, Endpoint @UNIX refLogAPI
|
||||
, Endpoint @UNIX lwwAPI
|
||||
, Endpoint @UNIX storageAPI
|
||||
]
|
||||
|
||||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||
|
||||
let app = MyStuff peerAPI lwwAPI refLogAPI sto ip
|
||||
|
||||
lift $ flip runReaderT app $ fromMyApp do
|
||||
merelySubscribeRepo ref
|
||||
|
||||
onProgress ip ImportAllDone
|
||||
|
||||
hFlush stdout
|
||||
hFlush stderr
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
@ -1,527 +0,0 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Git.Client.Prelude hiding (info, Input(..))
|
||||
import HBS2.Git.Client.App
|
||||
import HBS2.Git.Client.Export
|
||||
import HBS2.Git.Client.Import
|
||||
import HBS2.Git.Client.State
|
||||
import HBS2.Git.Client.Manifest
|
||||
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Git.Data.RepoHead
|
||||
import HBS2.Git.Data.RefLog
|
||||
import HBS2.Git.Local.CLI qualified as Git
|
||||
import HBS2.Git.Data.Tx.Git qualified as TX
|
||||
import HBS2.Git.Data.Tx.Git (RepoHead(..))
|
||||
import HBS2.Git.Data.Tx.Index
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
import HBS2.Peer.Proto.RefChan.Types
|
||||
import HBS2.Git.Data.GK
|
||||
|
||||
import HBS2.KeyMan.Keys.Direct
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.IO qualified as Text
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.Maybe
|
||||
import Data.List (nubBy)
|
||||
import Data.List qualified as L
|
||||
import Data.Function (on)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Coerce
|
||||
import Options.Applicative as O
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Prettyprinter
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.ByteString (ByteString)
|
||||
-- import Data.ByteString.Lazy (ByteString)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
import System.Exit
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
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 "fsck" (info pFsck (progDesc "check objects from a last reflog transaction"))
|
||||
<> command "key" (info pKey (progDesc "key management"))
|
||||
<> command "manifest" (info pManifest (progDesc "manifest commands"))
|
||||
<> command "track" (info pTrack (progDesc "track tools"))
|
||||
<> command "tools" (info pTools (progDesc "misc tools"))
|
||||
<> command "run" (info pRun (progDesc "run new cli command; run help to figure it out"))
|
||||
)
|
||||
|
||||
|
||||
pRefLogId :: ReadM RefLogId
|
||||
pRefLogId = maybeReader (fromStringMay @RefLogId)
|
||||
|
||||
pRefChanId :: ReadM GitRefChanId
|
||||
pRefChanId = maybeReader (fromStringMay @GitRefChanId)
|
||||
|
||||
pLwwKey :: ReadM (LWWRefKey 'HBS2Basic)
|
||||
pLwwKey = maybeReader fromStringMay
|
||||
|
||||
pHashRef :: ReadM HashRef
|
||||
pHashRef = maybeReader (fromStringMay @HashRef)
|
||||
|
||||
pInit :: GitPerks m => Parser (GitCLI m ())
|
||||
pInit = do
|
||||
pure runDefault
|
||||
|
||||
|
||||
pRun :: GitPerks m => Parser (GitCLI m ())
|
||||
pRun = do
|
||||
args <- many (strArgument (metavar "SCRIPT"))
|
||||
pure $ runScriptArgs args
|
||||
|
||||
pExport :: GitPerks m => Parser (GitCLI m ())
|
||||
pExport = do
|
||||
|
||||
puk <- argument pLwwKey (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.gitDir >>= 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
|
||||
unless (et == ExportNew) do
|
||||
importRepoWait puk
|
||||
|
||||
export puk mempty
|
||||
|
||||
pImport :: GitPerks m => Parser (GitCLI m ())
|
||||
pImport = do
|
||||
puk <- argument pLwwKey (metavar "LWWREF")
|
||||
|
||||
pure do
|
||||
git <- Git.gitDir >>= orThrowUser "not a git dir"
|
||||
importRepoWait puk
|
||||
|
||||
pFsck :: GitPerks m => Parser (GitCLI m ())
|
||||
pFsck = do
|
||||
lww <- argument pLwwKey (metavar "LWWREF")
|
||||
pure do
|
||||
git <- Git.gitDir >>= orThrowUser "not a git dir"
|
||||
fsckRepo lww
|
||||
|
||||
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"))
|
||||
<> command "show-remotes" (info pShowLww (progDesc "show current remotes (hbs2 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" )
|
||||
|
||||
|
||||
pShowLww :: GitPerks m => Parser (GitCLI m ())
|
||||
pShowLww = pure do
|
||||
items <- withState selectAllLww
|
||||
liftIO $ print $ vcat (fmap fmt items)
|
||||
where
|
||||
fmt (l,n,k) = fill 4 (pretty n) <+> fill 32 (pretty l) <+> fill 32 (pretty (AsBase58 k))
|
||||
|
||||
pShowRef :: GitPerks m => Parser (GitCLI m ())
|
||||
pShowRef = do
|
||||
remote <- strArgument (metavar "REMOTE")
|
||||
pure do
|
||||
runScript [mkList @C [mkSym "remote:refs:show", mkSym remote]]
|
||||
|
||||
pManifest :: GitPerks m => Parser (GitCLI m ())
|
||||
pManifest = hsubparser ( command "list" (info pManifestList (progDesc "list all manifest"))
|
||||
<> command "show" (info pManifestShow (progDesc "show manifest"))
|
||||
<> command "update" (info pManifestUpdate (progDesc "update manifest"))
|
||||
)
|
||||
|
||||
pManifestList :: GitPerks m => Parser (GitCLI m ())
|
||||
pManifestList = do
|
||||
what <- argument pLwwKey (metavar "LWWREF")
|
||||
pure do
|
||||
repoHeadRefs' <- withState $ selectRepoHeadsFor ASC what
|
||||
sto <- getStorage
|
||||
repoHeads <- for repoHeadRefs' $ \repoHeadRef -> runMaybeT $ do
|
||||
repoHead <- runExceptT (readFromMerkle sto (SimpleKey (coerce repoHeadRef)))
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @RepoHead
|
||||
>>= toMPlus
|
||||
pure (repoHeadRef, repoHead)
|
||||
let removeDuplicates = nubBy ((==) `on` (_repoManifest . snd))
|
||||
let filteredRepoHeads = removeDuplicates $ catMaybes repoHeads
|
||||
for_ filteredRepoHeads $ \(repoHeadRef, repoHead) -> do
|
||||
let mfLen = maybe 0 Text.length (_repoManifest repoHead)
|
||||
let mf = parens ("manifest length" <+> pretty mfLen)
|
||||
liftIO $ print $ pretty (_repoHeadTime repoHead)
|
||||
<+> pretty repoHeadRef
|
||||
<+> mf
|
||||
|
||||
pManifestShow :: GitPerks m => Parser (GitCLI m ())
|
||||
pManifestShow = do
|
||||
what <- argument pHashRef (metavar "HASH")
|
||||
pure do
|
||||
|
||||
sto <- getStorage
|
||||
rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce what)))
|
||||
>>= orThrowUser "repo head not found"
|
||||
<&> deserialiseOrFail @RepoHead
|
||||
>>= orThrowUser "repo head format not supported"
|
||||
|
||||
liftIO $ for_ (_repoManifest rhead) Text.putStrLn
|
||||
|
||||
data Input
|
||||
= FileInput FilePath
|
||||
| StdInput
|
||||
|
||||
manifestFileInput :: Parser Input
|
||||
manifestFileInput = FileInput <$> strOption
|
||||
( long "file"
|
||||
<> short 'f'
|
||||
<> metavar "FILENAME"
|
||||
<> help "Read manifest from file" )
|
||||
|
||||
manifestStdInput :: Parser Input
|
||||
manifestStdInput = flag' StdInput
|
||||
( long "stdin"
|
||||
<> help "Read manifest from stdin" )
|
||||
|
||||
pManifestUpdate :: (GitPerks m) => Parser (GitCLI m ())
|
||||
pManifestUpdate = do
|
||||
what <- argument pLwwKey (metavar "LWWREF")
|
||||
manifestInput <- manifestFileInput <|> manifestStdInput
|
||||
et <-
|
||||
flag
|
||||
ExportInc
|
||||
ExportNew
|
||||
( long "new" <> help "This flag is used for new repositories. It allows you to skip the step of downloading data from peers."
|
||||
)
|
||||
pure do
|
||||
manifest <- case manifestInput of
|
||||
FileInput f -> do
|
||||
t <- liftIO $ Text.readFile f
|
||||
addManifestBriefAndName $ Just t
|
||||
StdInput -> do
|
||||
t <- liftIO $ Text.getContents
|
||||
addManifestBriefAndName $ Just t
|
||||
env <- ask
|
||||
enc <- getRepoEnc
|
||||
let manifestUpdateEnv = Just $ ManifestUpdateEnv {_manifest = manifest}
|
||||
withGitEnv
|
||||
( env
|
||||
& set gitApplyHeads False
|
||||
& set gitExportType et
|
||||
& set gitExportEnc enc
|
||||
& set gitManifestUpdateEnv manifestUpdateEnv
|
||||
)
|
||||
do
|
||||
unless (et == ExportNew) do
|
||||
importRepoWait what
|
||||
export what mempty
|
||||
importRepoWait what
|
||||
|
||||
getRepoEnc :: (GitPerks m) => GitCLI m ExportEncryption
|
||||
getRepoEnc = do
|
||||
sto <- asks _storage
|
||||
mgkh <- runMaybeT do
|
||||
tx <- withState do
|
||||
selectMaxAppliedTx >>= lift . toMPlus <&> fst
|
||||
(_, rh) <-
|
||||
TX.readRepoHeadFromTx sto tx
|
||||
>>= toMPlus
|
||||
toMPlus $ _repoHeadGK0 rh
|
||||
case mgkh of
|
||||
Nothing -> pure ExportPublic
|
||||
Just gkh -> do
|
||||
gk <- runExceptT (readGK0 sto gkh) >>= orThrowUser "failed to read encryption key"
|
||||
pure $ ExportPrivateGK gk
|
||||
|
||||
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
|
||||
|
||||
|
||||
pTrack :: GitPerks m => Parser (GitCLI m ())
|
||||
pTrack = hsubparser ( command "send-repo-notify" (info pSendRepoNotify (progDesc "sends repository notification"))
|
||||
<> command "show-repo-notify" (info pShowRepoNotify (progDesc "shows repository notification"))
|
||||
<> command "gen-repo-index" (info pGenRepoIndex (progDesc "generates repo index tx"))
|
||||
)
|
||||
|
||||
pSendRepoNotify :: GitPerks m => Parser (GitCLI m ())
|
||||
pSendRepoNotify = do
|
||||
dry <- flag False True (short 'n' <> long "dry" <> help "don't post anything")
|
||||
notifyChan <- argument pRefChanId (metavar "CHANNEL-KEY")
|
||||
pure do
|
||||
notice $ "test send-repo-notify" <+> pretty (AsBase58 notifyChan)
|
||||
-- откуда мы берём ссылку, которую постим? их много.
|
||||
|
||||
lwws <- withState selectAllLww
|
||||
|
||||
-- берём те, для которых у нас есть приватный ключ (наши)
|
||||
creds <- catMaybes <$> runKeymanClient do
|
||||
for lwws $ \(lwref,_,_) -> do
|
||||
loadCredentials (coerce @_ @(PubKey 'Sign 'HBS2Basic) lwref)
|
||||
|
||||
sto <- getStorage
|
||||
rchanAPI <- asks _refChanAPI
|
||||
|
||||
hd <- getRefChanHead @L4Proto sto (RefChanHeadKey notifyChan)
|
||||
`orDie` "refchan head not found"
|
||||
|
||||
let notifiers = view refChanHeadNotifiers hd & HS.toList
|
||||
|
||||
-- откуда мы берём ключ, которым подписываем?
|
||||
-- ищем тоже в кеймане, берём тот, у которого выше weight
|
||||
foundKey <- runKeymanClient (
|
||||
S.head_ do
|
||||
for notifiers $ \n -> do
|
||||
lift (loadCredentials n) >>= maybe none S.yield
|
||||
) `orDie` "signing key not found"
|
||||
|
||||
for_ creds $ \c -> do
|
||||
let lww = LWWRefKey @'HBS2Basic (view peerSignPk c)
|
||||
let lwwSk = view peerSignSk c
|
||||
let tx = makeNotificationTx @'HBS2Basic (NotifyCredentials foundKey) lww lwwSk Nothing
|
||||
|
||||
notice $ "about to publish lwwref index entry:"
|
||||
<+> pretty (AsBase58 $ view peerSignPk c)
|
||||
|
||||
-- как мы постим ссылку
|
||||
unless dry do
|
||||
void $ callService @RpcRefChanNotify rchanAPI (notifyChan, tx)
|
||||
|
||||
-- кто парсит ссылку и помещает в рефчан
|
||||
|
||||
|
||||
pShowRepoNotify :: GitPerks m => Parser (GitCLI m ())
|
||||
pShowRepoNotify = do
|
||||
href <- argument pHashRef (metavar "HASH")
|
||||
pure do
|
||||
sto <- asks _storage
|
||||
|
||||
box <- getBlock sto (coerce href)
|
||||
`orDie` "tx not found"
|
||||
<&> deserialiseOrFail @(RefChanNotify L4Proto)
|
||||
>>= orThrowUser "malformed announce tx 1"
|
||||
>>= \case
|
||||
Notify _ box -> pure box
|
||||
_ -> throwIO (userError "malformed announce tx 2")
|
||||
|
||||
ann <- runExceptT (unpackNotificationTx box)
|
||||
>>= either (error . show) pure
|
||||
|
||||
liftIO $ print $ pretty ann
|
||||
|
||||
|
||||
pGenRepoIndex :: GitPerks m => Parser (GitCLI m ())
|
||||
pGenRepoIndex = do
|
||||
what <- argument pLwwKey (metavar "LWWREF")
|
||||
pure do
|
||||
hd <- withState $ selectRepoIndexEntryFor what
|
||||
>>= orThrowUser "no decent repo head data found"
|
||||
|
||||
seq <- getEpoch
|
||||
let tx = GitIndexTx what seq (GitIndexRepoDefine hd)
|
||||
liftIO $ LBS.putStr (serialise tx)
|
||||
|
||||
|
||||
script :: GitPerks m => Parser (GitCLI m ())
|
||||
script = do
|
||||
rest <- many (strArgument (metavar "CLI") )
|
||||
pure do
|
||||
cli <- parseTop (unlines $ unwords <$> splitForms rest)
|
||||
& either (error.show) pure
|
||||
void $ runScript cli
|
||||
|
||||
runScriptArgs :: GitPerks m => [String] -> GitCLI m ()
|
||||
runScriptArgs cli = do
|
||||
cli <- parseTop (unlines $ unwords <$> splitForms cli)
|
||||
& either (error.show) pure
|
||||
void $ runScript cli
|
||||
|
||||
runScript :: GitPerks m => [Syntax C] -> GitCLI m ()
|
||||
runScript syn = void $ run theDict syn
|
||||
|
||||
quit :: MonadIO m => m ()
|
||||
quit = liftIO exitSuccess
|
||||
|
||||
theDict :: forall m . ( GitPerks m
|
||||
-- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m
|
||||
) => Dict C (GitCLI m)
|
||||
theDict = do
|
||||
makeDict @C do
|
||||
-- TODO: write-man-entries
|
||||
myHelpEntry
|
||||
myEntries
|
||||
|
||||
where
|
||||
|
||||
myHelpEntry = do
|
||||
entry $ bindMatch "help" $ nil_ $ \case
|
||||
HelpEntryBound what -> do
|
||||
helpEntry what
|
||||
quit
|
||||
|
||||
[StringLike s] -> helpList False (Just s) >> quit
|
||||
|
||||
_ -> helpList False Nothing >> quit
|
||||
|
||||
|
||||
myEntries = do
|
||||
entry $ bindMatch "lww:fsck" $ nil_ $ \case
|
||||
[StringLike puk] -> lift do
|
||||
lww <- orThrowUser "bad lwwref key" (fromStringMay puk)
|
||||
git <- Git.gitDir >>= orThrowUser "not a git dir"
|
||||
fsckRepo lww
|
||||
|
||||
entry $ bindMatch "remote:hbs2:show" $ nil_ $ \case
|
||||
_ -> do
|
||||
-- TODO: move-to-HBS2.Local.CLI
|
||||
remotes <- Git.gitListHBS2Remotes
|
||||
let w = fmap (length.fst) remotes & maximumDef 8
|
||||
for_ remotes $ \(n,r) -> do
|
||||
liftIO $ print $ fill w (pretty n) <+> pretty (AsBase58 r)
|
||||
|
||||
entry $ bindMatch "remote:refs:show" $ nil_ $ \args -> lift do
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
remotez <- Git.gitListHBS2Remotes <&> HM.fromList
|
||||
let zetomer = HM.fromList [ (v,k) | (k,v) <- HM.toList remotez ]
|
||||
|
||||
lww <- case args of
|
||||
|
||||
[ StringLike x ] | x `HM.member` remotez -> do
|
||||
orThrowUser ( "remote" <+> pretty x <+> "not found" ) (HM.lookup x remotez)
|
||||
|
||||
[ SignPubKeyLike what ] | what `HM.member` zetomer -> do
|
||||
pure what
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
void $ runMaybeT do
|
||||
rh <- readActualRepoHeadFor (LWWRefKey lww)
|
||||
>>= toMPlus
|
||||
|
||||
liftIO $ print $ vcat (fmap formatRef (view repoHeadRefs rh))
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
|
@ -1,222 +0,0 @@
|
|||
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.RepoHead
|
||||
import HBS2.Git.Data.RefLog
|
||||
import HBS2.Git.Data.Tx.Git qualified as TX
|
||||
import HBS2.Git.Data.Tx.Git (RepoHead(..))
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
|
||||
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 (LWWRefKey 'HBS2Basic)
|
||||
parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
|
||||
where
|
||||
p = do
|
||||
void $ string "hbs21://" <|> string "hbs2://"
|
||||
|
||||
Atto.takeWhile1 (`elem` getAlphabet)
|
||||
<&> BS8.unpack
|
||||
<&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
>>= 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 "Reference" <+> 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
|
||||
)
|
||||
`catch` ( \(ImportTxApplyError h) -> do
|
||||
onProgress ip ImportAllDone
|
||||
pause @'Seconds 0.25
|
||||
liftIO $ hFlush stderr
|
||||
liftIO $ hPutDoc stderr $ red "Can not apply tx" <+> pretty h <> line <> line
|
||||
<> "It means you don't have a key do decrypt this tx or the data is not completely downloaded yet"
|
||||
<> line
|
||||
|
||||
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
|
||||
|
||||
|
||||
-- FIXME: may-cause-reference-inconsistency
|
||||
-- надо брать max(head) для lwwref
|
||||
-- а не максимальную транзу, накаченную на репо
|
||||
r' <- runMaybeT do
|
||||
-- tx <- selectMaxAppliedTx >>= lift . toMPlus <&> fst
|
||||
|
||||
-- (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
|
||||
rh <- liftIO (withGitEnv env (readActualRepoHeadFor puk))
|
||||
>>= toMPlus
|
||||
|
||||
pure (view 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 ""
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,205 +0,0 @@
|
|||
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.Git
|
||||
|
||||
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
|
||||
|
||||
ImportWaitLWW n lww -> do
|
||||
limit 0.25 $ put ("wait lwwref" <+> pretty lww <+> pretty n)
|
||||
next quiet
|
||||
|
||||
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
|
||||
|
||||
ImportApplyTxError h s -> do
|
||||
limit 0.25 $ put $ red ("failed" <+> pretty s) <+> 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)
|
||||
refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
|
||||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
||||
|
||||
let endpoints = [ Endpoint @UNIX peerAPI
|
||||
, Endpoint @UNIX refLogAPI
|
||||
, Endpoint @UNIX refChanAPI
|
||||
, Endpoint @UNIX lwwAPI
|
||||
, 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 refChanAPI lwwAPI 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
|
||||
|
||||
|
|
@ -1,172 +0,0 @@
|
|||
{-# 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.Git
|
||||
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)
|
||||
|
||||
|
||||
|
||||
newtype GitCLI m a = GitCLI { fromGitCLI :: ReaderT GitEnv m a }
|
||||
deriving newtype ( Applicative
|
||||
, Functor
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadTrans
|
||||
, MonadReader GitEnv
|
||||
, MonadThrow
|
||||
)
|
||||
|
||||
-- type GitPerks m = ( MonadUnliftIO m, MonadThrow m )
|
||||
type GitPerks m = ( MonadUnliftIO m )
|
||||
|
||||
instance Monad m => HasProgressIndicator (GitCLI m) where
|
||||
getProgressIndicator = asks _progress
|
||||
|
||||
instance Monad m => HasStorage (GitCLI m) where
|
||||
getStorage = asks _storage
|
||||
|
||||
instance Monad m => HasAPI PeerAPI UNIX (GitCLI m) where
|
||||
getAPI = asks _peerAPI
|
||||
|
||||
instance Monad m => HasAPI LWWRefAPI UNIX (GitCLI m) where
|
||||
getAPI = asks _lwwRefAPI
|
||||
|
||||
instance Monad m => HasAPI RefLogAPI UNIX (GitCLI m) where
|
||||
getAPI = asks _refLogAPI
|
||||
|
||||
instance MonadReader GitEnv m => HasAPI RefLogAPI UNIX (ExceptT e m) where
|
||||
getAPI = asks _refLogAPI
|
||||
|
||||
instance MonadReader GitEnv m => HasAPI LWWRefAPI UNIX (ExceptT e m) where
|
||||
getAPI = asks _lwwRefAPI
|
||||
|
||||
instance MonadReader GitEnv m => HasAPI PeerAPI UNIX (ExceptT e m) where
|
||||
getAPI = asks _peerAPI
|
||||
|
||||
newGitEnv :: GitPerks m
|
||||
=> AnyProgress
|
||||
-> [GitOption]
|
||||
-> FilePath
|
||||
-> FilePath
|
||||
-> Config
|
||||
-> ServiceCaller PeerAPI UNIX
|
||||
-> ServiceCaller RefLogAPI UNIX
|
||||
-> ServiceCaller RefChanAPI UNIX
|
||||
-> ServiceCaller LWWRefAPI UNIX
|
||||
-> ServiceCaller StorageAPI UNIX
|
||||
-> m GitEnv
|
||||
|
||||
newGitEnv p opts path cpath conf peer reflog rchan lww sto = do
|
||||
let dbfile = cpath </> "state.db"
|
||||
let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
|
||||
let manifestUpdateEnv = Nothing
|
||||
db <- newDBPipeEnv dOpt dbfile
|
||||
cache <- newTVarIO mempty
|
||||
pure $ GitEnv
|
||||
traceOpt
|
||||
debugOpt
|
||||
applyHeadsOpt
|
||||
exportType
|
||||
exportEnc
|
||||
manifestUpdateEnv
|
||||
path
|
||||
cpath
|
||||
conf
|
||||
peer
|
||||
reflog
|
||||
rchan
|
||||
lww
|
||||
(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
|
||||
|
||||
|
|
@ -1,63 +0,0 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Git.Client.App.Types.GitEnv where
|
||||
|
||||
import HBS2.Git.Client.Prelude hiding (info)
|
||||
|
||||
import HBS2.Git.Client.Progress
|
||||
|
||||
import HBS2.Git.Data.GK
|
||||
|
||||
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
|
||||
| ExportPrivateGK GK0
|
||||
deriving stock (Eq)
|
||||
|
||||
type Config = [Syntax C]
|
||||
|
||||
class Monad m => HasProgressIndicator m where
|
||||
getProgressIndicator :: m AnyProgress
|
||||
|
||||
class HasAPI api proto m where
|
||||
getAPI :: m (ServiceCaller api proto)
|
||||
|
||||
data ManifestUpdateEnv =
|
||||
ManifestUpdateEnv
|
||||
{ _manifest :: (Text, Text, Maybe Text)
|
||||
}
|
||||
|
||||
data GitEnv =
|
||||
GitEnv
|
||||
{ _gitTraceEnabled :: Bool
|
||||
, _gitDebugEnabled :: Bool
|
||||
, _gitApplyHeads :: Bool
|
||||
, _gitExportType :: ExportType
|
||||
, _gitExportEnc :: ExportEncryption
|
||||
, _gitManifestUpdateEnv :: Maybe ManifestUpdateEnv
|
||||
, _gitPath :: FilePath
|
||||
, _configPath :: FilePath
|
||||
, _config :: Config
|
||||
, _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _refChanAPI :: ServiceCaller RefChanAPI UNIX
|
||||
, _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX
|
||||
, _db :: DBPipeEnv
|
||||
, _progress :: AnyProgress
|
||||
, _keyringCache :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic])
|
||||
}
|
||||
|
||||
|
||||
makeLenses 'GitEnv
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
module HBS2.Git.Client.Config (getConfigDir, readConfig, hbs2Name) where
|
||||
|
||||
import HBS2.Git.Client.Prelude
|
||||
import HBS2.Git.Client.App.Types
|
||||
|
||||
import HBS2.System.Dir
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
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"
|
||||
|
||||
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
|
||||
|]
|
||||
|
|
@ -1,352 +0,0 @@
|
|||
module HBS2.Git.Client.Export (export) where
|
||||
|
||||
|
||||
import HBS2.Git.Client.Prelude hiding (info)
|
||||
import HBS2.Git.Client.App.Types
|
||||
import HBS2.Git.Client.Manifest
|
||||
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.Git
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
import HBS2.Git.Data.GK
|
||||
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
import HBS2.KeyMan.Keys.Direct
|
||||
|
||||
import HBS2.OrDie
|
||||
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
|
||||
import Data.Coerce
|
||||
|
||||
data ExportError = ExportUnsupportedOperation
|
||||
| ExportBundleCreateError
|
||||
deriving stock (Show,Typeable)
|
||||
|
||||
instance Exception ExportError
|
||||
|
||||
instance HasErrorStatus ExportError where
|
||||
getStatus = \case
|
||||
ExportUnsupportedOperation -> Failed
|
||||
ExportBundleCreateError -> 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
|
||||
<&> HashMap.fromList
|
||||
<&> HashMap.mapWithKey (\k v -> if k `HashSet.member` deleted then gitHashTomb else v)
|
||||
<&> 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
|
||||
gk <- case enc of
|
||||
ExportPrivate f -> loadGK0FromFile f >>= toMPlus
|
||||
ExportPrivateGK k -> toMPlus $ Just k
|
||||
_ -> toMPlus Nothing
|
||||
epoch <- getEpoch
|
||||
writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch)
|
||||
|
||||
export :: ( GitPerks m
|
||||
, MonadReader GitEnv m
|
||||
, GroupKeyOperations m
|
||||
, HasAPI PeerAPI UNIX m
|
||||
)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> [(GitRef,Maybe GitHash)]
|
||||
-> m ()
|
||||
export key refs = do
|
||||
|
||||
git <- asks _gitPath
|
||||
sto <- asks _storage
|
||||
new <- asks _gitExportType <&> (== ExportNew)
|
||||
manifestUpdateEnv <- asks _gitManifestUpdateEnv
|
||||
reflog <- asks _refLogAPI
|
||||
ip <- asks _progress
|
||||
|
||||
subscribeLWWRef key
|
||||
|
||||
(lww, LWWBlockData{..}) <- waitOrInitLWWRef
|
||||
|
||||
let puk0 = fromLwwRefKey key
|
||||
|
||||
debug $ red $ pretty $ AsBase58 lwwRefLogPubKey
|
||||
|
||||
(sk0,pk0) <- liftIO $ runKeymanClient do
|
||||
creds <- loadCredentials puk0
|
||||
>>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0))
|
||||
pure ( view peerSignSk creds, view peerSignPk creds )
|
||||
|
||||
(puk,sk) <- derivedKey @'HBS2Basic @'Sign lwwRefSeed sk0
|
||||
|
||||
subscribeRefLog puk
|
||||
|
||||
myrefs <- refsForExport refs
|
||||
|
||||
let myrefsKey = L.sortOn fst myrefs & serialise & hashObject @HbSync & HashRef
|
||||
|
||||
flip runContT pure do
|
||||
callCC \exit -> do
|
||||
|
||||
|
||||
tx0 <- getLastAppliedTx key
|
||||
|
||||
rh <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus )
|
||||
|
||||
let rh0 = snd <$> rh
|
||||
|
||||
(name,brief,mf) <- case manifestUpdateEnv of
|
||||
-- TODO: do not update manifest if not needed
|
||||
Nothing -> lift $ getLastManifestFromStorage key
|
||||
Just (ManifestUpdateEnv manifest) -> pure manifest
|
||||
|
||||
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)
|
||||
|
||||
let updateManifest = isJust manifestUpdateEnv
|
||||
|
||||
when (null objs && not new && oldRefs == myrefs && not updateManifest) 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 (const $ pure (Just sk)) 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
|
||||
|
||||
findSK pk = liftIO $ runKeymanClient $ runMaybeT do
|
||||
creds <- lift (loadCredentials pk) >>= toMPlus
|
||||
pure (view peerSignSk creds)
|
||||
|
||||
waitOrInitLWWRef = do
|
||||
sto <- asks _storage
|
||||
new <- asks _gitExportType <&> (== ExportNew)
|
||||
|
||||
flip fix 3 $ \next n -> do
|
||||
blk <- readLWWBlock sto key
|
||||
|
||||
case blk of
|
||||
Just x -> pure x
|
||||
|
||||
Nothing | new && n > 0 -> do
|
||||
_ <- runExceptT (initLWWRef sto Nothing findSK key)
|
||||
>>= either ( throwIO . userError . show ) pure
|
||||
|
||||
next (pred n)
|
||||
|
||||
| otherwise -> do
|
||||
-- FIXME: detailed-error-description
|
||||
orThrowUser "lwwref not available" Nothing
|
||||
|
||||
|
||||
notInTx Nothing _ = pure True
|
||||
notInTx (Just tx0) obj = not <$> isObjectInTx tx0 obj
|
||||
|
||||
getLastAppliedTx lww = runMaybeT do
|
||||
(tx0,_) <- withState (selectMaxAppliedTxForRepo lww)
|
||||
>>= 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
|
||||
|
||||
|
||||
|
|
@ -1,544 +0,0 @@
|
|||
module HBS2.Git.Client.Import where
|
||||
|
||||
import HBS2.Git.Client.Prelude hiding (info)
|
||||
import HBS2.Git.Client.App.Types
|
||||
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.Git
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
import HBS2.Git.Data.RepoHead
|
||||
|
||||
import HBS2.Data.Detect (readLogThrow)
|
||||
import HBS2.Merkle.Walk
|
||||
import HBS2.Peer.Proto.LWWRef
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage.AdHocStorage
|
||||
import HBS2.Storage.Operations.Missed
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
-- import HBS2.Git.Data.GK
|
||||
-- import HBS2.Git.Data.RepoHead
|
||||
import HBS2.Storage.Operations.Class
|
||||
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
|
||||
import Control.Arrow ((>>>))
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Streaming.Prelude qualified as S
|
||||
import System.IO (hPrint)
|
||||
import Data.Maybe
|
||||
|
||||
data ImportRefLogNotFound = ImportRefLogNotFound
|
||||
deriving stock (Typeable,Show)
|
||||
|
||||
instance Exception ImportRefLogNotFound
|
||||
|
||||
|
||||
data ImportTxApplyError = ImportTxApplyError HashRef
|
||||
deriving stock (Typeable,Show)
|
||||
|
||||
|
||||
instance Exception ImportTxApplyError
|
||||
|
||||
|
||||
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 =
|
||||
IWaitLWWBlock Int
|
||||
| IWaitRefLog Int RefLogId
|
||||
| IScanRefLog RefLogId HashRef
|
||||
| IApplyTx HashRef
|
||||
| IExit
|
||||
|
||||
|
||||
-- class
|
||||
|
||||
merelySubscribeRepo :: forall e s m . ( GitPerks m
|
||||
, HasStorage m
|
||||
, HasProgressIndicator m
|
||||
, HasAPI PeerAPI UNIX m
|
||||
, HasAPI LWWRefAPI UNIX m
|
||||
, HasAPI RefLogAPI UNIX m
|
||||
, e ~ L4Proto
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> m (Maybe (PubKey 'Sign s))
|
||||
merelySubscribeRepo lwwKey = do
|
||||
|
||||
ip <- getProgressIndicator
|
||||
sto <- getStorage
|
||||
|
||||
subscribeLWWRef lwwKey
|
||||
fetchLWWRef lwwKey
|
||||
|
||||
r <- flip fix (IWaitLWWBlock 10) $ \next -> \case
|
||||
|
||||
IWaitLWWBlock w | w <= 0 -> do
|
||||
throwIO ImportRefLogNotFound
|
||||
|
||||
IWaitLWWBlock w -> do
|
||||
onProgress ip (ImportWaitLWW w lwwKey)
|
||||
lww <- readLWWBlock sto lwwKey
|
||||
|
||||
case lww of
|
||||
Nothing -> do
|
||||
pause @'Seconds 2
|
||||
fetchLWWRef lwwKey
|
||||
next (IWaitLWWBlock (pred w))
|
||||
|
||||
Just (_, LWWBlockData{..}) -> do
|
||||
void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey)
|
||||
subscribeRefLog lwwRefLogPubKey
|
||||
pause @'Seconds 0.25
|
||||
pure $ Just lwwRefLogPubKey
|
||||
|
||||
_ -> pure Nothing
|
||||
|
||||
onProgress ip ImportAllDone
|
||||
pure r
|
||||
|
||||
importRepoWait :: ( GitPerks m
|
||||
, MonadReader GitEnv m
|
||||
, HasAPI PeerAPI UNIX m
|
||||
, HasAPI LWWRefAPI UNIX m
|
||||
, HasAPI RefLogAPI UNIX m
|
||||
)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> m ()
|
||||
|
||||
importRepoWait lwwKey = do
|
||||
|
||||
env <- ask
|
||||
|
||||
ip <- asks _progress
|
||||
sto <- asks _storage
|
||||
|
||||
meet <- newTVarIO (mempty :: HashMap HashRef Int)
|
||||
|
||||
subscribeLWWRef lwwKey
|
||||
|
||||
fetchLWWRef lwwKey
|
||||
|
||||
flip fix (IWaitLWWBlock 20) $ \next -> \case
|
||||
|
||||
IWaitLWWBlock w | w <= 0 -> do
|
||||
throwIO ImportRefLogNotFound
|
||||
|
||||
IWaitLWWBlock w -> do
|
||||
onProgress ip (ImportWaitLWW w lwwKey)
|
||||
lww <- readLWWBlock sto lwwKey
|
||||
|
||||
case lww of
|
||||
Nothing -> do
|
||||
pause @'Seconds 2
|
||||
fetchLWWRef lwwKey
|
||||
next (IWaitLWWBlock (pred w))
|
||||
|
||||
Just (LWWRef{..}, LWWBlockData{..}) -> do
|
||||
|
||||
withState do
|
||||
insertLww lwwKey lwwSeq lwwRefLogPubKey
|
||||
|
||||
void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey)
|
||||
subscribeRefLog lwwRefLogPubKey
|
||||
pause @'Seconds 0.25
|
||||
getRefLogMerkle lwwRefLogPubKey
|
||||
next (IWaitRefLog 20 lwwRefLogPubKey)
|
||||
|
||||
IWaitRefLog w puk | w <= 0 -> do
|
||||
throwIO ImportRefLogNotFound
|
||||
|
||||
IWaitRefLog w puk -> do
|
||||
onProgress ip (ImportRefLogStart puk)
|
||||
try @_ @SomeException (getRefLogMerkle puk) >>= \case
|
||||
Left _ -> do
|
||||
onProgress ip (ImportRefLogDone puk Nothing)
|
||||
pause @'Seconds 2
|
||||
next (IWaitRefLog (pred w) puk)
|
||||
|
||||
Right Nothing -> do
|
||||
onProgress ip (ImportRefLogDone puk Nothing)
|
||||
pause @'Seconds 2
|
||||
next (IWaitRefLog (pred w) puk)
|
||||
|
||||
Right (Just h) -> do
|
||||
onProgress ip (ImportRefLogDone puk (Just h))
|
||||
next (IScanRefLog puk h)
|
||||
|
||||
IScanRefLog puk 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 puk h)
|
||||
|
||||
IApplyTx h -> do
|
||||
onProgress ip (ImportApplyTx h)
|
||||
|
||||
r <- runExceptT (applyTx h)
|
||||
`catch` \case
|
||||
ImportUnbundleError{} -> pure (Left IncompleteData)
|
||||
_ -> throwIO (userError "tx apply / state read error")
|
||||
|
||||
|
||||
case r of
|
||||
|
||||
Left MissedBlockError -> do
|
||||
next =<< repeatOrExit
|
||||
|
||||
Left IncompleteData -> do
|
||||
atomically $ modifyTVar meet (HM.insertWith (+) h 1)
|
||||
onProgress ip (ImportApplyTxError h (Just "read/decrypt"))
|
||||
attempts <- readTVarIO meet <&> fromMaybe 0 . HM.lookup h
|
||||
|
||||
when (attempts >= 10 ) do
|
||||
throwIO (ImportTxApplyError h)
|
||||
|
||||
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 (IWaitLWWBlock 5)
|
||||
|
||||
newtype CanNotReadLWWBlock = CanNotReadLWWBlock (LWWRefKey HBS2Basic)
|
||||
deriving (Show) via (AsBase58 (LWWRefKey HBS2Basic))
|
||||
instance Exception CanNotReadLWWBlock
|
||||
|
||||
newtype CanNotReadLWWHashRef = CanNotReadLWWHashRef (PubKey Sign HBS2Basic)
|
||||
deriving (Show)
|
||||
instance Exception CanNotReadLWWHashRef
|
||||
|
||||
newtype NoBlocksInMerkle = NoBlocksInMerkle HashRef
|
||||
deriving (Show)
|
||||
instance Exception NoBlocksInMerkle
|
||||
|
||||
newtype GetBlockError = GetBlockError HashRef
|
||||
deriving (Show)
|
||||
instance Exception GetBlockError
|
||||
|
||||
newtype GetOrFetchBlockError = GetOrFetchBlockError (Hash HbSync)
|
||||
deriving (Show)
|
||||
instance Exception GetOrFetchBlockError
|
||||
|
||||
newtype FsckError = FsckError Text
|
||||
deriving (Show)
|
||||
instance Exception FsckError
|
||||
|
||||
fsckRepo :: ( GitPerks m
|
||||
, MonadReader GitEnv m
|
||||
, HasAPI PeerAPI UNIX m
|
||||
, HasAPI LWWRefAPI UNIX m
|
||||
, HasAPI RefLogAPI UNIX m
|
||||
)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> m ()
|
||||
|
||||
fsckRepo lwwKey = do
|
||||
env <- ask
|
||||
sto' <- asks _storage
|
||||
peerAPI <- getAPI @PeerAPI @UNIX
|
||||
|
||||
let
|
||||
getBF = getBlockOrFetch callBlockFetch (getBlock sto')
|
||||
getBJ = fmap Just . getBF
|
||||
|
||||
let
|
||||
getBJ' :: Hash HbSync -> IO (Maybe LBS.ByteString)
|
||||
getBJ' = fmap Just . getBlockOrFetch (callBlockFetchIO peerAPI) (getBlock sto')
|
||||
sto = AnyStorage (AdHocStorage @IO sto' getBJ')
|
||||
|
||||
(LWWRef{..}, LWWBlockData{..}) <- maybe (throwIO (CanNotReadLWWBlock lwwKey)) pure
|
||||
=<< readLWWBlock sto lwwKey
|
||||
|
||||
hr <- maybe (throwIO (CanNotReadLWWHashRef lwwRefLogPubKey)) pure
|
||||
=<< getRefLogMerkle lwwRefLogPubKey
|
||||
liftIO . print $ "Reflog merkle hash:" <+> pretty hr
|
||||
|
||||
-- mapM_ (liftIO . print . pretty) =<< readLogThrow getBJ hr
|
||||
|
||||
-- readLogThrow getBJ hr >>= mapM_ \txh -> do
|
||||
|
||||
txh <- maybe (throwIO (NoBlocksInMerkle hr)) pure
|
||||
=<< S.last_ do
|
||||
(orThrowPassIO <=< streamMerkle @HashRef getBJ)
|
||||
(fromHashRef hr)
|
||||
do
|
||||
|
||||
liftIO . print $ "tx:" <+> pretty txh
|
||||
|
||||
txbs <- getBF (fromHashRef txh)
|
||||
<&> deserialiseOrFail @(RefLogUpdate L4Proto)
|
||||
>>= orThrow UnsupportedFormat
|
||||
|
||||
(n, rhh, blkh) <- unpackTx txbs
|
||||
|
||||
rh <- catFromMerkle
|
||||
(fmap Just . getBF)
|
||||
(fromHashRef rhh)
|
||||
>>= orThrowPassIO
|
||||
>>= (deserialiseOrFail @RepoHead >>> orThrow UnsupportedFormat)
|
||||
|
||||
findMissedBlocks2 sto blkh
|
||||
& S.mapM_ (getBF . fromHashRef)
|
||||
|
||||
liftIO . print $ "All blocks fetched for tx" <+> pretty txh
|
||||
|
||||
-- Double check. Ensure readTx has everything needed
|
||||
_ <- (orThrowPassIO <=< runExceptT) do
|
||||
readTx sto txh
|
||||
|
||||
bundlesCount <- (orThrowPassIO . runStreamOfA <=< S.length) do
|
||||
streamMerkle @HashRef getBJ (fromHashRef blkh)
|
||||
& S.mapM (\bh -> bh <$ getBF (fromHashRef blkh))
|
||||
& S.mapM (orThrowPassIO <=< runExceptT . readBundle sto rh)
|
||||
|
||||
liftIO . print $ "All bundles (" <+> pretty bundlesCount
|
||||
<+> ") fetched and checked for tx" <+> pretty txh
|
||||
|
||||
where
|
||||
callBlockFetch
|
||||
:: ( MonadUnliftIO m
|
||||
, HasAPI PeerAPI UNIX m
|
||||
)
|
||||
=> Hash HbSync -> m ()
|
||||
callBlockFetch h = do
|
||||
peerAPI <- getAPI @PeerAPI @UNIX
|
||||
liftIO $ callBlockFetchIO peerAPI h
|
||||
|
||||
callBlockFetchIO :: ServiceCaller PeerAPI UNIX -> Hash HbSync -> IO ()
|
||||
callBlockFetchIO peerAPI h = do
|
||||
race (pause @'Seconds 1)
|
||||
(callService @RpcFetch peerAPI (HashRef h))
|
||||
>>= orThrow BlockFetchRequestTimeout
|
||||
>>= orThrow BlockFetchRequestError
|
||||
|
||||
data BlockFetchRequestTimeout = BlockFetchRequestTimeout deriving (Show)
|
||||
instance Exception BlockFetchRequestTimeout
|
||||
|
||||
data BlockFetchRequestError = BlockFetchRequestError deriving (Show)
|
||||
instance Exception BlockFetchRequestError
|
||||
|
||||
getBlockOrFetch
|
||||
:: (MonadIO m)
|
||||
=> (Hash HbSync -> m ())
|
||||
-> (Hash HbSync -> m (Maybe LBS.ByteString))
|
||||
-> Hash HbSync -> m LBS.ByteString
|
||||
getBlockOrFetch fetch getB h = do
|
||||
getB h >>= flip maybe pure do
|
||||
fetch h
|
||||
liftIO . print $ "Fetch block:" <+> pretty h
|
||||
flip fix 1 \go attempt -> do
|
||||
liftIO $ threadDelay (attempt * 10^6)
|
||||
getB h >>= flip maybe pure do
|
||||
if attempt < numAttempts
|
||||
then go (attempt + 1)
|
||||
else throwIO (GetOrFetchBlockError h)
|
||||
where
|
||||
numAttempts = 12
|
||||
|
||||
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 = view 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 ()
|
||||
|
||||
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
module HBS2.Git.Client.Manifest (getLastManifestFromStorage, addManifestBriefAndName) where
|
||||
|
||||
import Data.Coerce
|
||||
import Data.Either
|
||||
import Data.List qualified as L
|
||||
import Data.Maybe
|
||||
import Data.Text qualified as Text
|
||||
import HBS2.Git.Client.App.Types
|
||||
import HBS2.Git.Client.Config
|
||||
import HBS2.Git.Client.Prelude
|
||||
import HBS2.Git.Client.State
|
||||
import HBS2.Git.Data.RepoHead
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
import HBS2.System.Dir
|
||||
|
||||
addManifestBriefAndName :: (GitPerks m) => Maybe Text -> m (Text, Text, Maybe Text)
|
||||
addManifestBriefAndName manifest = do
|
||||
dir <- getConfigDir
|
||||
let defBrief = "n/a"
|
||||
defName = takeFileName (takeDirectory dir) & Text.pack
|
||||
-- FIXME: size-hardcode
|
||||
header =
|
||||
lines (take 1024 (Text.unpack $ fromMaybe "" manifest))
|
||||
& takeWhile (not . L.null)
|
||||
& unlines
|
||||
& parseTop
|
||||
& fromRight mempty
|
||||
name = lastDef defName [n | ListVal [SymbolVal "name:", LitStrVal n] <- header]
|
||||
brief = lastDef defBrief [n | ListVal [SymbolVal "brief:", LitStrVal n] <- header]
|
||||
pure (name, brief, manifest)
|
||||
|
||||
getLastManifestFromStorage ::
|
||||
( MonadReader GitEnv m,
|
||||
GitPerks m
|
||||
) =>
|
||||
LWWRefKey 'HBS2Basic ->
|
||||
m (Text, Text, Maybe Text)
|
||||
getLastManifestFromStorage lwwref = do
|
||||
manifest <- runMaybeT do
|
||||
sto <- asks _storage
|
||||
headRef <- MaybeT $ withState $ selectLastRepoHeadFor lwwref
|
||||
rhead <-
|
||||
runExceptT (readFromMerkle sto (SimpleKey (coerce headRef)))
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @RepoHead
|
||||
>>= toMPlus
|
||||
MaybeT $ pure $ _repoManifest rhead
|
||||
addManifestBriefAndName manifest
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Git.Client.Progress where
|
||||
|
||||
import HBS2.Git.Client.Prelude
|
||||
import HBS2.Git.Data.RefLog
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
|
||||
import HBS2.Git.Data.Tx.Git
|
||||
|
||||
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
|
||||
| ImportWaitLWW Int (LWWRefKey 'HBS2Basic)
|
||||
| ImportRefLogStart RefLogId
|
||||
| ImportRefLogDone RefLogId (Maybe HashRef)
|
||||
| ImportWaitTx HashRef
|
||||
| ImportScanTx HashRef
|
||||
| ImportApplyTx HashRef
|
||||
| ImportApplyTxError HashRef (Maybe String)
|
||||
| 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
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
module HBS2.Git.Client.RefLog
|
||||
( module HBS2.Git.Client.RefLog
|
||||
, module HBS2.Peer.Proto.RefLog
|
||||
) where
|
||||
|
||||
import HBS2.Git.Client.Prelude
|
||||
import HBS2.Git.Client.App.Types
|
||||
import HBS2.Git.Data.RefLog
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
import HBS2.Peer.Proto.RefLog
|
||||
|
||||
data RefLogRequestTimeout = RefLogRequestTimeout
|
||||
deriving (Show,Typeable)
|
||||
|
||||
data RefLogRequestError = RefLogRequestError
|
||||
deriving (Show,Typeable)
|
||||
|
||||
instance Exception RefLogRequestTimeout
|
||||
|
||||
instance Exception RefLogRequestError
|
||||
|
||||
doSomeRandomShit :: HasAPI PeerAPI UNIX m => m ()
|
||||
doSomeRandomShit = error "FUCK"
|
||||
|
||||
subscribeRefLog :: forall m .(GitPerks m, HasAPI PeerAPI UNIX m) => RefLogId -> m ()
|
||||
subscribeRefLog puk = do
|
||||
api <- getAPI @PeerAPI @UNIX
|
||||
void $ callService @RpcPollAdd api (puk, "reflog", 13)
|
||||
|
||||
subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
subscribeLWWRef puk = do
|
||||
api <- getAPI @PeerAPI @UNIX
|
||||
void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17)
|
||||
|
||||
fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
fetchLWWRef key = do
|
||||
api <- getAPI @LWWRefAPI @UNIX
|
||||
void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)
|
||||
|
||||
getRefLogMerkle :: forall m . (GitPerks m, HasAPI RefLogAPI UNIX m) => RefLogId -> m (Maybe HashRef)
|
||||
getRefLogMerkle puk = do
|
||||
|
||||
api <- getAPI @RefLogAPI @UNIX
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,506 +0,0 @@
|
|||
{-# 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.Peer.Proto.RefLog
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
|
||||
import HBS2.Git.Data.RepoHead
|
||||
import HBS2.Git.Data.RefLog
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
import HBS2.Git.Data.Tx.Index
|
||||
import HBS2.Git.Data.Tx.Git qualified as TX
|
||||
-- import HBS2.Git.Data.Tx qualified as TX
|
||||
|
||||
import DBPipe.SQLite
|
||||
import Data.Maybe
|
||||
import Data.List qualified as List
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Word
|
||||
import Data.Coerce
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
data Limit = Limit Integer
|
||||
|
||||
data SortOrder = ASC | DESC
|
||||
|
||||
newtype SQL a = SQL a
|
||||
|
||||
instance Pretty (SQL SortOrder) where
|
||||
pretty (SQL ASC) = "ASC"
|
||||
pretty (SQL DESC) = "DESC"
|
||||
|
||||
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 FromField (RefLogKey 'HBS2Basic) where
|
||||
fromField = fmap fromString . fromField @String
|
||||
|
||||
instance ToField HashRef where
|
||||
toField h = toField @String (show $ pretty h)
|
||||
|
||||
instance FromField HashRef where
|
||||
fromField = fmap fromString . fromField @String
|
||||
|
||||
deriving newtype instance FromField (TaggedHashRef t)
|
||||
|
||||
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
|
||||
|
||||
instance FromField (LWWRefKey 'HBS2Basic) 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
|
||||
createLwwTable
|
||||
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)
|
||||
)
|
||||
|]
|
||||
|
||||
|
||||
createLwwTable :: MonadIO m => DBPipeM m ()
|
||||
createLwwTable = do
|
||||
ddl [qc|
|
||||
create table if not exists lww
|
||||
( hash text not null
|
||||
, seq int not null
|
||||
, reflog text not null
|
||||
, primary key (hash,seq,reflog)
|
||||
)
|
||||
|]
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
selectMaxAppliedTxForRepo :: MonadIO m => LWWRefKey 'HBS2Basic -> DBPipeM m (Maybe (HashRef, Integer))
|
||||
selectMaxAppliedTxForRepo lww = do
|
||||
select [qc|
|
||||
with rl as (
|
||||
select l.hash, l.reflog from lww l where l.hash = ?
|
||||
order by seq desc limit 1
|
||||
)
|
||||
select t.tx, t.seq
|
||||
from txdone d join tx t on d.tx = t.tx
|
||||
join rl on rl.reflog = t.reflog
|
||||
order by t.seq desc limit 1
|
||||
|] (Only (Base58Field lww))
|
||||
<&> 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
|
||||
|
||||
|
||||
insertLww :: MonadIO m => LWWRefKey 'HBS2Basic -> Word64 -> RefLogId -> DBPipeM m ()
|
||||
insertLww lww snum reflog = do
|
||||
insert [qc|
|
||||
INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?)
|
||||
ON CONFLICT (hash,seq,reflog) DO NOTHING
|
||||
|] (Base58Field lww, snum, Base58Field reflog)
|
||||
|
||||
selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey 'HBS2Basic, Word64, RefLogId)]
|
||||
selectAllLww = do
|
||||
select_ [qc|
|
||||
SELECT hash, seq, reflog FROM lww
|
||||
|] <&> fmap (over _3 (fromRefLogKey @'HBS2Basic))
|
||||
|
||||
|
||||
|
||||
selectRepoHeadsFor :: (MonadIO m)
|
||||
=> SortOrder
|
||||
-> LWWRefKey 'HBS2Basic
|
||||
-> DBPipeM m [TaggedHashRef RepoHead]
|
||||
|
||||
selectRepoHeadsFor order what = do
|
||||
let q = [qc|
|
||||
SELECT t.head
|
||||
FROM lww l join tx t on l.reflog = t.reflog
|
||||
WHERE l.hash = ?
|
||||
ORDER BY t.seq {pretty (SQL order)}
|
||||
|]
|
||||
|
||||
select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what)
|
||||
<&> fmap fromOnly
|
||||
|
||||
selectLastRepoHeadFor :: (MonadIO m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> DBPipeM m (Maybe (TaggedHashRef RepoHead))
|
||||
|
||||
selectLastRepoHeadFor what = do
|
||||
let q = [qc|
|
||||
SELECT t.head
|
||||
FROM lww l join tx t on l.reflog = t.reflog
|
||||
WHERE l.hash = ?
|
||||
ORDER BY t.seq DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
|
||||
select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what)
|
||||
<&> (fmap fromOnly . listToMaybe)
|
||||
|
||||
instance (Monad m, HasStorage m) => HasStorage (DBPipeM m) where
|
||||
getStorage = lift getStorage
|
||||
|
||||
selectRepoIndexEntryFor :: (MonadIO m, HasStorage m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> DBPipeM m (Maybe GitIndexRepoDefineData)
|
||||
|
||||
selectRepoIndexEntryFor what = runMaybeT do
|
||||
|
||||
headz <- lift $ selectRepoHeadsFor DESC what
|
||||
|
||||
rhh <- S.head_ do
|
||||
for_ headz $ \ha -> do
|
||||
rh' <- lift $ loadRepoHead ha
|
||||
for_ rh' $ \rh -> do
|
||||
when (notEmpty $ _repoManifest rh) do
|
||||
S.yield rh
|
||||
|
||||
|
||||
repohead <- toMPlus rhh
|
||||
|
||||
pure $ GitIndexRepoDefineData (GitIndexRepoName $ _repoHeadName repohead)
|
||||
(GitIndexRepoBrief $ _repoHeadBrief repohead)
|
||||
|
||||
|
||||
where
|
||||
notEmpty s = maybe 0 Text.length s > 0
|
||||
|
||||
loadRepoHead :: (HasStorage m, MonadIO m) => TaggedHashRef RepoHead -> m (Maybe RepoHead)
|
||||
loadRepoHead rh = do
|
||||
sto <- getStorage
|
||||
runMaybeT do
|
||||
runExceptT (readFromMerkle sto (SimpleKey (coerce rh)))
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @RepoHead
|
||||
>>= toMPlus
|
||||
|
||||
readActualRepoHeadFor :: ( HasStorage m
|
||||
, MonadReader GitEnv m
|
||||
, MonadIO m
|
||||
)
|
||||
=> LWWRefKey 'HBS2Basic -> m (Maybe RepoHead)
|
||||
|
||||
readActualRepoHeadFor lww = do
|
||||
sto <- getStorage
|
||||
runMaybeT do
|
||||
tx <- lift ( withState $
|
||||
selectMaxAppliedTxForRepo lww
|
||||
<&> fmap fst
|
||||
) >>= toMPlus
|
||||
|
||||
(_,rh) <- TX.readRepoHeadFromTx sto tx >>= toMPlus
|
||||
pure rh
|
||||
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
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)
|
||||
|
||||
|
|
@ -1,137 +0,0 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Git.Data.LWWBlock
|
||||
( module HBS2.Git.Data.LWWBlock
|
||||
, module HBS2.Peer.Proto.LWWRef
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Auth.Schema()
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Storage
|
||||
import HBS2.Peer.Proto.LWWRef
|
||||
|
||||
import Data.Word
|
||||
import Codec.Serialise
|
||||
import System.Random
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
-- NOTE: on-lww-block-data
|
||||
-- HKDF ( SK(LWWRef) , lwwRefNonce ) ==> SK( RefLog )
|
||||
-- lwwRefLogPubKey == PK ( SK (RefLog ) )
|
||||
--
|
||||
-- LWWBlock is required to make repo reference "stable",
|
||||
-- i.e. it should remains the same even if the structure
|
||||
-- of repository has been changed or it was, say, "trimmed".
|
||||
--
|
||||
-- Therefore, there is the root key and the LWWRef, pointing
|
||||
-- to a block, which contains actual seed data for the "current"
|
||||
-- repo and it's possible to support permanent reference (LWWRef)
|
||||
-- to a repo, while it's actual structure may be changed
|
||||
-- (hbs2-git repo structure changes or garbage collecting (removing old
|
||||
-- transactions, etc).
|
||||
--
|
||||
-- (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX])
|
||||
--
|
||||
|
||||
data LWWBlockData s =
|
||||
LWWBlockData
|
||||
{ lwwRefSeed :: Word64
|
||||
, lwwRefLogPubKey :: PubKey 'Sign s
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
data LWWBlock s =
|
||||
LWWBlock1 { lwwBlockData :: LWWBlockData s }
|
||||
deriving stock Generic
|
||||
|
||||
instance Serialise (PubKey 'Sign s) => Serialise (LWWBlockData s)
|
||||
instance Serialise (PubKey 'Sign s) => Serialise (LWWBlock s)
|
||||
|
||||
|
||||
data LWWBlockOpError =
|
||||
LWWBlockOpSkNotAvail
|
||||
| LWWBlockOpStorageError
|
||||
| LWWBlockOpSomeError
|
||||
deriving stock (Show,Typeable,Generic)
|
||||
|
||||
instance Exception LWWBlockOpError
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
readLWWBlock :: forall s m . ( MonadIO m
|
||||
, Signatures s
|
||||
, ForLWWRefProto s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
=> AnyStorage
|
||||
-> LWWRefKey s
|
||||
-> m (Maybe (LWWRef s, LWWBlockData s))
|
||||
|
||||
readLWWBlock sto k = runMaybeT do
|
||||
|
||||
w@LWWRef{..} <- runExceptT (readLWWRef @s sto k)
|
||||
>>= toMPlus
|
||||
>>= toMPlus
|
||||
|
||||
getBlock sto (fromHashRef lwwValue)
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @(LWWBlock s)
|
||||
>>= toMPlus
|
||||
<&> lwwBlockData
|
||||
<&> (w,)
|
||||
|
||||
initLWWRef :: forall s m . ( MonadIO m
|
||||
, MonadError LWWBlockOpError m
|
||||
, IsRefPubKey s
|
||||
, ForSignedBox s
|
||||
, HasDerivedKey s 'Sign Word64 m
|
||||
, Signatures s
|
||||
)
|
||||
=> AnyStorage
|
||||
-> Maybe Word64
|
||||
-> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
|
||||
-> LWWRefKey s
|
||||
-> m HashRef
|
||||
initLWWRef sto seed' findSk lwwKey = do
|
||||
-- let k0 = fromLwwRefKey lww
|
||||
seed <- maybe1 seed' randomIO pure
|
||||
|
||||
let pk0 = fromLwwRefKey lwwKey
|
||||
sk0 <- findSk pk0
|
||||
>>= orThrowError LWWBlockOpSkNotAvail
|
||||
|
||||
lww0 <- runMaybeT do
|
||||
getRef sto lwwKey >>= toMPlus
|
||||
>>= getBlock sto >>= toMPlus
|
||||
<&> deserialiseOrFail @(SignedBox (LWWRef s) s)
|
||||
>>= toMPlus
|
||||
<&> unboxSignedBox0
|
||||
>>= toMPlus
|
||||
<&> snd
|
||||
|
||||
(pk1, _) <- derivedKey @s @'Sign seed sk0
|
||||
|
||||
let newLwwData = LWWBlock1 @s (LWWBlockData seed pk1)
|
||||
|
||||
hx <- putBlock sto (serialise newLwwData)
|
||||
>>= orThrowError LWWBlockOpStorageError
|
||||
<&> HashRef
|
||||
|
||||
let lww :: LWWRef e
|
||||
lww = LWWRef { lwwSeq = succ (maybe 0 lwwSeq lww0)
|
||||
, lwwValue = hx
|
||||
, lwwProof = Nothing
|
||||
}
|
||||
|
||||
updateLWWRef @s sto lwwKey sk0 lww
|
||||
>>= orThrowError LWWBlockOpStorageError
|
||||
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
module HBS2.Git.Data.RefLog where
|
||||
|
||||
import HBS2.Git.Client.Prelude
|
||||
|
||||
type RefLogId = PubKey 'Sign 'HBS2Basic
|
||||
|
||||
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
module HBS2.Git.Data.RepoHead where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Data.Types.Refs
|
||||
|
||||
import HBS2.Git.Local
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Data.ByteString.Char8 qualified as B8
|
||||
import Data.Word
|
||||
import Codec.Serialise
|
||||
import Lens.Micro.Platform
|
||||
import Data.Coerce
|
||||
import Safe
|
||||
import Data.Maybe
|
||||
import Data.Set qualified as Set
|
||||
|
||||
data RepoHeadType = RepoHeadType1
|
||||
deriving stock (Enum,Generic,Show)
|
||||
|
||||
data RepoHeadExt = RepoHeadExt
|
||||
deriving stock (Generic,Show)
|
||||
|
||||
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,Show)
|
||||
|
||||
makeLenses ''RepoHead
|
||||
|
||||
repoHeadTags :: SimpleGetter RepoHead [(GitRef,GitHash)]
|
||||
repoHeadTags =
|
||||
to \h@RepoHeadSimple{} -> do
|
||||
catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef)
|
||||
| (GitRef s, v) <- view repoHeadRefs h, B8.isPrefixOf "refs/tags" s
|
||||
] & Set.fromList & Set.toList
|
||||
|
||||
|
||||
repoHeadHeads :: SimpleGetter RepoHead [(GitRef,GitHash)]
|
||||
repoHeadHeads =
|
||||
to \h@RepoHeadSimple{} -> do
|
||||
catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef)
|
||||
| (GitRef s, v) <- view repoHeadRefs h, B8.isPrefixOf "refs/heads" s
|
||||
] & Set.fromList & Set.toList
|
||||
|
||||
|
||||
repoHeadRefs :: Lens RepoHead
|
||||
RepoHead
|
||||
[(GitRef, GitHash)]
|
||||
[(GitRef, GitHash)]
|
||||
|
||||
repoHeadRefs = lens g s
|
||||
where
|
||||
s rh r = rh { repoHeadRefs' = r }
|
||||
g rh = [ (r,v) | (r,v) <- repoHeadRefs' rh, v /= gitHashTomb ]
|
||||
|
||||
instance Serialise RepoHeadType
|
||||
instance Serialise RepoHeadExt
|
||||
instance Serialise RepoHead
|
||||
|
|
@ -1,371 +0,0 @@
|
|||
module HBS2.Git.Data.Tx.Git
|
||||
( module HBS2.Git.Data.Tx.Git
|
||||
, OperationError(..)
|
||||
, RepoHead(..)
|
||||
) 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.Data.RepoHead
|
||||
|
||||
import HBS2.Git.Local
|
||||
import HBS2.Merkle.Walk
|
||||
|
||||
|
||||
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 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 :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ 'HBS2Basic)
|
||||
=> AnyStorage
|
||||
-> Bool -- ^ rewrite bundle merkle tree with new gk0
|
||||
-> Rank -- ^ tx rank
|
||||
-> RefLogId
|
||||
-> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
|
||||
-> RepoHead
|
||||
-> [HashRef]
|
||||
-> [LBS]
|
||||
-> m RepoTx
|
||||
|
||||
makeTx sto rewrite r puk findSk rh prev lbss = do
|
||||
|
||||
let rfk = RefLogKey @'HBS2Basic puk
|
||||
|
||||
privk <- findSk puk
|
||||
>>= orThrow TxKeyringNotFound
|
||||
|
||||
-- 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
|
||||
|
||||
-- FIXME: ASAP-race-condition-on-seq-ref
|
||||
-- При разборе транзакции, если по какой-то причине
|
||||
-- голова сразу не подъезжает, то не подъедет уже никогда,
|
||||
-- и бранчи не приедут (Import).
|
||||
--
|
||||
-- Возможные решения: запатчить процедуру импорта (1)
|
||||
-- Добавить ссылкун а RepoHead в блок, где приезжают
|
||||
-- пулы
|
||||
|
||||
-- TODO: post-real-rank-for-tx
|
||||
let tx = SequentialRef r (AnnotatedHashRef (Just headRef) meRef)
|
||||
& serialise
|
||||
& LBS.toStrict
|
||||
|
||||
makeRefLogUpdate @L4Proto @'HBS2Basic puk 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 (HashRef, 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
|
||||
<&> (rhh,)
|
||||
|
||||
|
||||
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
|
||||
|
||||
let findSec = runKeymanClientRO . findMatchedGroupKeySecret sto
|
||||
|
||||
case q of
|
||||
Merkle t -> do
|
||||
let meta = BundleMeta ref False
|
||||
BundleWithMeta meta <$>
|
||||
readFromMerkle sto (SimpleKey key)
|
||||
|
||||
MerkleAnn (MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
|
||||
let meta = BundleMeta ref True
|
||||
BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS key (liftIO . findSec))
|
||||
|
||||
_ -> throwError UnsupportedFormat
|
||||
|
||||
where
|
||||
key = fromHashRef ref
|
||||
|
||||
readBundleRefs :: (MonadIO m)
|
||||
=> AnyStorage
|
||||
-> HashRef
|
||||
-> m (Either [HashRef] [HashRef])
|
||||
|
||||
readBundleRefs sto bunh = do
|
||||
(hs S.:> er) <- S.toList $ streamMerkle @HashRef (getBlock sto) (fromHashRef bunh)
|
||||
case er of
|
||||
Left wme -> case wme of
|
||||
MerkleHashNotFound h -> pure (Left [HashRef h])
|
||||
MerkleDeserialiseFailure h _ -> pure (Left [HashRef h])
|
||||
Right () -> pure (Right hs)
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,128 +0,0 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Git.Data.Tx.Index where
|
||||
|
||||
import HBS2.Git.Client.Prelude
|
||||
import HBS2.Git.Data.RepoHead
|
||||
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Storage.Operations.Class
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Coerce
|
||||
|
||||
import Data.Word
|
||||
|
||||
-- |
|
||||
-- Module : HBS2.Git.Data.Tx.Index
|
||||
-- Description : hbs2-git index data structures
|
||||
--
|
||||
|
||||
-- FIXME: fix-all-this-constraint-absurde
|
||||
type ForGitIndex s = ( ForSignedBox s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
|
||||
data RepoForkInfo e =
|
||||
RepoForkInfoNone
|
||||
deriving stock (Generic)
|
||||
|
||||
data GitRepoAnnounce s =
|
||||
GitRepoAnnounce
|
||||
{ repoLwwRef :: LWWRefKey s
|
||||
, repoForkInfo :: Maybe (RepoForkInfo s)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
instance ForGitIndex s => Serialise (RepoForkInfo s)
|
||||
instance ForGitIndex s => Serialise (GitRepoAnnounce s)
|
||||
|
||||
instance ForGitIndex s => Pretty (GitRepoAnnounce s) where
|
||||
pretty GitRepoAnnounce{..} = parens $ "git-repo-announce" <+> pretty repoLwwRef
|
||||
|
||||
newtype NotifyCredentials s = NotifyCredentials (PeerCredentials s)
|
||||
|
||||
newtype GitIndexRepoName = GitIndexRepoName Text
|
||||
deriving stock (Data,Generic,Show)
|
||||
deriving newtype (Serialise)
|
||||
|
||||
newtype GitIndexRepoBrief = GitIndexRepoBrief Text
|
||||
deriving stock (Data,Generic,Show)
|
||||
deriving newtype (Serialise)
|
||||
|
||||
newtype GitIndexRepoManifest = GitIndexRepoManifest (Maybe Text)
|
||||
deriving stock (Generic,Show)
|
||||
deriving newtype (Serialise)
|
||||
|
||||
data GitIndexRepoDefineData =
|
||||
GitIndexRepoDefineData
|
||||
{ gitIndexRepoName :: GitIndexRepoName
|
||||
, gitIndexRepoBrief :: GitIndexRepoBrief
|
||||
}
|
||||
deriving stock (Data,Generic,Show)
|
||||
|
||||
data GitIndexEntry =
|
||||
GitIndexRepoDefine GitIndexRepoDefineData
|
||||
| GitIndexRepoTombEntry
|
||||
| GitIndexRepoLikes Integer
|
||||
deriving stock (Data,Generic)
|
||||
|
||||
data GitIndexTx s =
|
||||
GitIndexTx
|
||||
{ gitIndexTxRef :: LWWRefKey s -- ^ primary key
|
||||
, gitIndexTxSeq :: Word64 -- ^ sequence ( set tomb / bring from tomb )
|
||||
, gitIndexTxPayload :: GitIndexEntry -- ^ statement
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForGitIndex s => Serialise (GitIndexTx s)
|
||||
instance Serialise GitIndexRepoDefineData
|
||||
instance Serialise GitIndexEntry
|
||||
|
||||
instance ForGitIndex s => Pretty (GitIndexTx s) where
|
||||
pretty GitIndexTx{..} = case gitIndexTxPayload of
|
||||
GitIndexRepoDefine{} -> "git-repo-define" <+> pretty gitIndexTxRef
|
||||
GitIndexRepoTombEntry -> "git-repo-tomb" <+> pretty gitIndexTxRef
|
||||
GitIndexRepoLikes n -> "git-repo-likes" <+> pretty gitIndexTxRef <+> pretty n
|
||||
|
||||
-- | makes notification tx
|
||||
-- | it is signed by lwwref private key in order to proove authorship
|
||||
-- | and signed with published notification private key in order
|
||||
-- | to publish tx via rpc
|
||||
makeNotificationTx :: forall s . (ForGitIndex s)
|
||||
=> NotifyCredentials s
|
||||
-> LWWRefKey s
|
||||
-> PrivKey 'Sign s
|
||||
-> Maybe (RepoForkInfo s)
|
||||
-> SignedBox ByteString s
|
||||
makeNotificationTx ncred lww lwsk forkInfo = do
|
||||
let creds = coerce ncred :: PeerCredentials s
|
||||
let annData = GitRepoAnnounce @s lww forkInfo
|
||||
let lwpk = coerce lww :: PubKey 'Sign s
|
||||
let repoAnn = makeSignedBox @s lwpk lwsk (LBS.toStrict $ serialise annData)
|
||||
makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict $ serialise repoAnn)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
unpackNotificationTx :: forall s m . (ForGitIndex s, MonadError OperationError m)
|
||||
=> SignedBox ByteString s
|
||||
-> m (GitRepoAnnounce s)
|
||||
unpackNotificationTx box = do
|
||||
(_, bs1) <- unboxSignedBox0 @_ @s box
|
||||
& orThrowError SignCheckError
|
||||
|
||||
bs2 <- deserialiseOrFail @(SignedBox ByteString s) (LBS.fromStrict bs1)
|
||||
& orThrowError UnsupportedFormat
|
||||
|
||||
(_, bs3) <- unboxSignedBox0 bs2
|
||||
& orThrowError SignCheckError
|
||||
|
||||
deserialiseOrFail @(GitRepoAnnounce s) (LBS.fromStrict bs3)
|
||||
& orThrowError UnsupportedFormat
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,173 +0,0 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2-git
|
||||
version: 0.25.0.1
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
author: Dmitry Zuikov
|
||||
-- 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-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
, aeson
|
||||
, 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
|
||||
import: shared-properties
|
||||
|
||||
exposed-modules:
|
||||
HBS2.Git.Local
|
||||
HBS2.Git.Local.CLI
|
||||
|
||||
HBS2.Git.Data.Tx.Git
|
||||
HBS2.Git.Data.Tx.Index
|
||||
HBS2.Git.Data.RepoHead
|
||||
HBS2.Git.Data.GK
|
||||
HBS2.Git.Data.RefLog
|
||||
HBS2.Git.Data.LWWBlock
|
||||
|
||||
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
|
||||
HBS2.Git.Client.Manifest
|
||||
|
||||
build-depends: base
|
||||
, base16-bytestring
|
||||
, binary
|
||||
, unix
|
||||
|
||||
hs-source-dirs: hbs2-git-client-lib
|
||||
|
||||
|
||||
-- executable hbs2-git-subscribe
|
||||
-- import: shared-properties
|
||||
-- main-is: Main.hs
|
||||
-- -- other-modules:
|
||||
-- -- other-extensions:
|
||||
-- build-depends:
|
||||
-- base, hbs2-git
|
||||
-- , binary
|
||||
-- , vector
|
||||
-- , optparse-applicative
|
||||
|
||||
-- hs-source-dirs: git-hbs2-subscribe
|
||||
-- default-language: GHC2021
|
||||
|
||||
-- executable git-hbs2
|
||||
-- import: shared-properties
|
||||
-- main-is: Main.hs
|
||||
-- -- other-modules:
|
||||
-- -- other-extensions:
|
||||
-- build-depends:
|
||||
-- base, hbs2-git
|
||||
-- , binary
|
||||
-- , vector
|
||||
-- , optparse-applicative
|
||||
|
||||
-- hs-source-dirs: git-hbs2
|
||||
-- default-language: GHC2021
|
||||
|
||||
|
||||
-- executable git-remote-hbs2
|
||||
-- import: shared-properties
|
||||
-- main-is: Main.hs
|
||||
-- -- other-modules:
|
||||
-- -- other-extensions:
|
||||
-- build-depends:
|
||||
-- base, hbs2-git
|
||||
-- , binary
|
||||
-- , vector
|
||||
-- , optparse-applicative
|
||||
|
||||
-- hs-source-dirs: git-remote-hbs2
|
||||
-- default-language: GHC2021
|
||||
|
||||
|
||||
|
|
@ -59,7 +59,6 @@ common shared-properties
|
|||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman-direct-lib
|
||||
, hbs2-git
|
||||
, hbs2-cli
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
|
@ -121,6 +120,9 @@ library
|
|||
other-modules:
|
||||
|
||||
exposed-modules:
|
||||
HBS2.Git.Client.Prelude
|
||||
HBS2.Git.Local
|
||||
HBS2.Git.Local.CLI
|
||||
HBS2.Git3.Types
|
||||
HBS2.Git3.Prelude
|
||||
HBS2.Git3.Export
|
||||
|
|
@ -162,7 +164,7 @@ executable hbs2-git3
|
|||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer
|
||||
, binary
|
||||
, psqueues
|
||||
, vector
|
||||
|
|
@ -178,7 +180,7 @@ executable git-remote-hbs23
|
|||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer
|
||||
, binary
|
||||
, vector
|
||||
, ansi-terminal
|
||||
|
|
@ -191,8 +193,8 @@ test-suite spec
|
|||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
|
||||
other-modules:
|
||||
HBS2.Git3.Git.PackSpec
|
||||
-- other-modules:
|
||||
-- HBS2.Git3.Git.PackSpec
|
||||
-- Data.Config.Suckless.KeyValueSpec
|
||||
-- Data.Config.Suckless.AesonSpec
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue