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-peer
|
||||||
, hbs2-storage-simple
|
, hbs2-storage-simple
|
||||||
, hbs2-keyman-direct-lib
|
, hbs2-keyman-direct-lib
|
||||||
, hbs2-git
|
, hbs2-git3
|
||||||
, hbs2-cli
|
, hbs2-cli
|
||||||
, db-pipe
|
, db-pipe
|
||||||
, suckless-conf
|
, suckless-conf
|
||||||
|
|
@ -135,7 +135,7 @@ executable fixme-new
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends:
|
build-depends:
|
||||||
base, fixme-new, hbs2-core, hbs2-peer, hbs2-git
|
base, fixme-new, hbs2-core, hbs2-peer
|
||||||
, binary
|
, binary
|
||||||
, vector
|
, vector
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
|
|
||||||
|
|
@ -33,7 +33,6 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
||||||
"hbs2-peer"
|
"hbs2-peer"
|
||||||
"hbs2-core"
|
"hbs2-core"
|
||||||
"hbs2-storage-simple"
|
"hbs2-storage-simple"
|
||||||
"hbs2-git"
|
|
||||||
"hbs2-git3"
|
"hbs2-git3"
|
||||||
"hbs2-cli"
|
"hbs2-cli"
|
||||||
"hbs2-sync"
|
"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-peer
|
||||||
, hbs2-storage-simple
|
, hbs2-storage-simple
|
||||||
, hbs2-keyman-direct-lib
|
, hbs2-keyman-direct-lib
|
||||||
, hbs2-git
|
|
||||||
, hbs2-cli
|
, hbs2-cli
|
||||||
, db-pipe
|
, db-pipe
|
||||||
, suckless-conf
|
, suckless-conf
|
||||||
|
|
@ -121,6 +120,9 @@ library
|
||||||
other-modules:
|
other-modules:
|
||||||
|
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
HBS2.Git.Client.Prelude
|
||||||
|
HBS2.Git.Local
|
||||||
|
HBS2.Git.Local.CLI
|
||||||
HBS2.Git3.Types
|
HBS2.Git3.Types
|
||||||
HBS2.Git3.Prelude
|
HBS2.Git3.Prelude
|
||||||
HBS2.Git3.Export
|
HBS2.Git3.Export
|
||||||
|
|
@ -162,7 +164,7 @@ executable hbs2-git3
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends:
|
build-depends:
|
||||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
base, hbs2-git3, hbs2-core, hbs2-peer
|
||||||
, binary
|
, binary
|
||||||
, psqueues
|
, psqueues
|
||||||
, vector
|
, vector
|
||||||
|
|
@ -178,7 +180,7 @@ executable git-remote-hbs23
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends:
|
build-depends:
|
||||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
base, hbs2-git3, hbs2-core, hbs2-peer
|
||||||
, binary
|
, binary
|
||||||
, vector
|
, vector
|
||||||
, ansi-terminal
|
, ansi-terminal
|
||||||
|
|
@ -191,8 +193,8 @@ test-suite spec
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
|
|
||||||
other-modules:
|
-- other-modules:
|
||||||
HBS2.Git3.Git.PackSpec
|
-- HBS2.Git3.Git.PackSpec
|
||||||
-- Data.Config.Suckless.KeyValueSpec
|
-- Data.Config.Suckless.KeyValueSpec
|
||||||
-- Data.Config.Suckless.AesonSpec
|
-- Data.Config.Suckless.AesonSpec
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue