voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
voidlizard 2025-01-19 20:51:46 +03:00
parent b5410825c3
commit 3d27321241
7 changed files with 127 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
hbs2-git3/app/GitRemoteHelper.hs
View File

@ -11,10 +11,12 @@ import HBS2.Git3.Import
import HBS2.Git3.Export
import HBS2.Git3.Git
import Data.Config.Suckless
import System.Posix.Signals
import System.IO qualified as IO
import System.Exit qualified as Exit
import System.Environment (getArgs)
import System.Environment (getArgs,lookupEnv)
import Text.InterpolatedString.Perl6 (qc)
import Data.Text qualified as Text
import Data.Maybe
@ -35,7 +37,7 @@ getLine = liftIO IO.getLine
sendLine :: MonadIO m => String -> m ()
sendLine = liftIO . IO.putStrLn
die :: (MonadIO m, Pretty a) => a -> m b
die :: forall a m . (MonadIO m, Pretty a) => a -> m ()
die s = liftIO $ Exit.die (show $ pretty s)
parseCLI :: MonadIO m => m [Syntax C]
@ -77,6 +79,17 @@ data DeferredOps =
{ exportQ :: TQueue (GitRef, Maybe GitHash)
}
pattern RepoURL :: GitRemoteKey -> Syntax C
pattern RepoURL x <- (isRepoURL -> Just x)
isRepoURL :: Syntax C -> Maybe GitRemoteKey
isRepoURL = \case
TextLike xs -> case mkStr @C <$> headMay (drop 1 (Text.splitOn "://" xs)) of
Just (SignPubKeyLike puk) -> Just puk
_ -> Nothing
_ -> Nothing
localDict :: forall m . ( HBS2GitPerks m
-- , HasClientAPI PeerAPI UNIX m
@ -92,16 +105,20 @@ localDict DeferredOps{..} = makeDict @C do
sendLine "fetch"
sendLine ""
entry $ bindMatch "r:list" $ nil_ $ \syn -> lift do
importGitRefLog
entry $ bindMatch "r:list" $ nil_ $ const $ lift $ connectedDo do
reflog <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed
rrefs <- importedRefs
notice $ red "REFLOG" <+> pretty (AsBase58 reflog)
for_ rrefs $ \(r,h) -> do
debug $ pretty h <+> pretty r
sendLine $ show $ pretty h <+> pretty r
importGitRefLog
sendLine ""
rrefs <- importedRefs
for_ rrefs $ \(r,h) -> do
debug $ pretty h <+> pretty r
sendLine $ show $ pretty h <+> pretty r
sendLine ""
entry $ bindMatch "r:push" $ nil_ $ splitPushArgs $ \pushFrom pushTo -> lift do
r0 <- for pushFrom gitRevParseThrow
@ -152,13 +169,22 @@ main = flip runContT pure do
let dict = theDict <> localDict ops
git <- liftIO $ lookupEnv "GIT_DIR"
notice $ red "GIT" <+> pretty git
void $ lift $ withGit3Env env do
conf <- readLocalConf
cli <- parseCLI
notice $ pretty cli
case cli of
[ ListVal [_, RepoURL url ] ] -> do
notice $ "FUCKING REMOTE" <+> pretty (AsBase58 url)
setGitRepoKey url
_ -> none
void $ run dict conf
@ -175,7 +201,7 @@ main = flip runContT pure do
when (null (words inp)) $ next End
debug $ pretty "INPUT" <+> pretty inp
notice $ pretty "INPUT" <+> pretty inp
runTop dict ("r:"<>inp)

6
hbs2-git3/lib/HBS2/Git3/Config/Local.hs
View File

@ -19,7 +19,7 @@ getConfigPath = do
let name = ".hbs2-git3"
findGitDir
gitDir
>>= orThrowUser ".git not found"
<&> (</> name) . takeDirectory
@ -29,7 +29,7 @@ getConfigRootFile = do
let name = ".hbs2-git3"
findGitDir
gitDir
>>= orThrowUser ".git not found"
<&> (</> name) . takeDirectory
<&> (</> "config")
@ -43,6 +43,6 @@ readLocalConf = do
liftIO (IO.readFile conf)
<&> parseTop
>>= either (error.show) pure
>>= either (const $ pure mempty) pure

24
hbs2-git3/lib/HBS2/Git3/Export.hs
View File

@ -11,7 +11,7 @@ import HBS2.Data.Detect
import HBS2.Data.Log.Structured
import HBS2.CLI.Run.Internal.Merkle (createTreeWithMetadata)
import HBS2.CLI.Run.RefLog (mkRefLogUpdateFrom)
-- import HBS2.CLI.Run.RefLog (mkRefLogUpdateFrom)
import HBS2.System.Dir
@ -25,6 +25,7 @@ import Data.ByteString.Builder as Builder
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString qualified as BS
import Data.ByteString (ByteString)
import Data.Fixed
import Data.HashPSQ qualified as HPSQ
import Data.HashPSQ (HashPSQ)
@ -55,6 +56,11 @@ data ECC =
| ECCFinalize Int Bool FilePath Handle Result
genRefLogUpdate :: forall m . MonadUnliftIO m => ByteString -> Git3 m (RefLogUpdate L4Proto)
genRefLogUpdate txraw = do
(puk,privk) <- getRepoRefLogCredentials
makeRefLogUpdate @L4Proto @'HBS2Basic puk privk txraw
exportEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) ()
exportEntries prefix = do
entry $ bindMatch (prefix <> "export") $ nil_ $ \syn -> lift $ connectedDo do
@ -147,8 +153,8 @@ export mbh refs = do
writeLogEntry ("tree" <+> pretty ts <+> pretty href)
debug $ "SENDING" <+> pretty href <+> pretty fn
let payload = pure $ LBS.toStrict $ serialise (AnnotatedHashRef Nothing href)
tx <- mkRefLogUpdateFrom (coerce reflog) payload
let payload = LBS.toStrict $ serialise (AnnotatedHashRef Nothing href)
tx <- withGit3Env env $ genRefLogUpdate payload
let txh = hashObject @HbSync (serialise tx) & HashRef
@ -342,13 +348,13 @@ export mbh refs = do
-- checks if all transactions written to reflog
-- post tx with current reflog value
postCheckPoint :: forall m1 . ( MonadUnliftIO m1
, HasStorage m1
, HasClientAPI RefLogAPI UNIX m1
, HasGitRemoteKey m1
-- , HasStorage m1
-- , HasClientAPI RefLogAPI UNIX m1
-- , HasGitRemoteKey m1
)
=> Timeout 'Seconds
-> HashSet HashRef
-> m1 (Maybe HashRef)
-> Git3 m1 (Maybe HashRef)
postCheckPoint _ txq | HS.null txq = pure Nothing
postCheckPoint t txq = perform >>= either (const $ throwIO ExportWriteTimeout) pure
@ -380,8 +386,8 @@ export mbh refs = do
pure x
t0 <- liftIO getPOSIXTime <&> round
let payload = pure $ LBS.toStrict $ serialise (SequentialRef t0 (AnnotatedHashRef Nothing cp))
tx <- mkRefLogUpdateFrom (coerce reflog) payload
let payload = LBS.toStrict $ serialise (SequentialRef t0 (AnnotatedHashRef Nothing cp))
tx <- genRefLogUpdate payload
callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) api tx
>>= orThrow ExportWriteTimeout

2
hbs2-git3/lib/HBS2/Git3/Import.hs
View File

@ -118,7 +118,7 @@ importGitRefLog = do
updateReflogIndex
packs <- findGitDir
packs <- gitDir
>>= orThrowUser "git directory not found"
<&> (</> "objects/pack")

18
hbs2-git3/lib/HBS2/Git3/Run.hs
View File

@ -374,7 +374,7 @@ theDict = do
for_ hashes $ \h -> do
liftIO $ print $ pretty h
entry $ bindMatch "reflog:index:list:fast" $ nil_ $ const $ lift do
entry $ bindMatch "reflog:index:list:fast" $ nil_ $ const $ lift $ connectedDo do
files <- listObjectIndexFiles
forConcurrently_ files $ \(f,_) -> do
bs <- liftIO $ mmapFileByteString f Nothing
@ -386,13 +386,13 @@ theDict = do
notice $ pretty sha1 <+> pretty blake
entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift do
entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift $ connectedDo do
idx <- openIndex
num_ <- newIORef 0
enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x))
readIORef num_ >>= liftIO . print . pretty
entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift do
entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift $ connectedDo do
files <- listObjectIndexFiles
for_ files $ \(ifn,_) -> do
lbs <- liftIO $ LBS.readFile ifn
@ -414,22 +414,22 @@ theDict = do
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift do
entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift $ connectedDo do
size <- getIndexBlockSize
compactIndex size
entry $ bindMatch "reflog:index:path" $ nil_ $ const $ lift do
entry $ bindMatch "reflog:index:path" $ nil_ $ const $ lift $ connectedDo do
indexPath >>= liftIO . print . pretty
-- let entriesListOf lbs = S.toList_ $ runConsumeLBS lbs $ readSections $ \s ss -> do
entry $ bindMatch "reflog:index:files" $ nil_ $ \syn -> lift do
entry $ bindMatch "reflog:index:files" $ nil_ $ \syn -> lift $ connectedDo do
files <- listObjectIndexFiles
cur <- pwd
for_ files $ \(f',s) -> do
let f = makeRelative cur f'
liftIO $ print $ fill 10 (pretty s) <+> pretty f
entry $ bindMatch "reflog:index:list:tx" $ nil_ $ const $ lift do
entry $ bindMatch "reflog:index:list:tx" $ nil_ $ const $ lift $ connectedDo do
r <- newIORef ( mempty :: HashSet HashRef )
index <- openIndex
enumEntries index $ \bs -> do
@ -580,6 +580,10 @@ theDict = do
liftIO $ print $ pretty reflog
entry $ bindMatch "repo:credentials" $ nil_ $ const $ lift $ connectedDo do
(p,_) <- getRepoRefLogCredentials
liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )]
entry $ bindMatch "repo:key:show" $ nil_ $ const $ lift do
r <- getGitRepoKey >>= orThrow GitRepoRefNotSet
liftIO $ print $ pretty (AsBase58 r)

61
hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs
View File

@ -9,6 +9,7 @@ module HBS2.Git3.State.Internal.Types
import HBS2.Git3.Prelude
import HBS2.Git3.Config.Local
import HBS2.Net.Auth.Credentials
import HBS2.KeyMan.Keys.Direct
import HBS2.System.Dir
import HBS2.Data.Detect (readLogThrow)
import HBS2.CLI.Run.MetaData (getTreeContents)
@ -40,10 +41,12 @@ import HBS2.System.Logger.Simple.ANSI as Exported
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Data.ByteString.Lazy qualified as LBS
import Data.Word
import Data.Kind
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Lens.Micro.Platform
import System.FilePath
@ -60,6 +63,7 @@ data HBS2GitExcepion =
| GitRepoRefNotSet
| GitRepoRefEmpty
| GitRepoManifestMalformed
| RefLogCredentialsNotMatched
| RpcTimeout
deriving stock (Show,Typeable)
@ -180,6 +184,21 @@ getStatePathM = do
k <- getGitRemoteKey >>= orThrow RefLogNotSet
getStatePath (AsBase58 k)
updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m ()
updateRepoKey key = do
setGitRepoKey key
mf <- getRepoManifest
let reflog = lastMay [ x
| ListVal [SymbolVal "reflog", SignPubKeyLike x] <- mf
]
ask >>= \case
Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog
_ -> none
getRepoRefMaybe :: forall m . HBS2GitPerks m => Git3 m (Maybe (LWWRef 'HBS2Basic))
getRepoRefMaybe = do
lwwAPI <- getClientAPI @LWWRefAPI @UNIX
@ -189,6 +208,32 @@ getRepoRefMaybe = do
callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey pk)
>>= orThrow RpcTimeout
getRepoRefLogCredentials :: forall m . HBS2GitPerks m
=> Git3 m (PubKey 'Sign 'HBS2Basic, PrivKey 'Sign HBS2Basic)
getRepoRefLogCredentials = do
-- FIXME: memoize-this
mf <- getRepoManifest
rk <- getGitRepoKey >>= orThrow GitRepoRefNotSet
reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet
creds <- runKeymanClientRO (loadCredentials rk)
>>= orThrowUser ("not found credentials for" <+> pretty (AsBase58 rk))
seed <- [ x | ListVal [SymbolVal "seed", LitIntVal x ] <- mf ]
& lastMay & orThrow GitRepoManifestMalformed
<&> fromIntegral @_ @Word64
let sk = view peerSignSk creds
(p,s) <- derivedKey @'HBS2Basic @'Sign seed sk
unless ( p == reflog ) do
throwIO RefLogCredentialsNotMatched
pure (p,s)
getRepoManifest :: forall m . HBS2GitPerks m => Git3 m [Syntax C]
getRepoManifest = do
@ -296,10 +341,12 @@ recover m = fix \again -> do
let sto = AnyStorage (StorageClient storageAPI)
rk <- lift getGitRepoKey
rk <- lift $ getGitRepoKey >>= orThrow GitRepoRefNotSet
notice $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk)
connected <- Git3Connected soname sto peer refLogAPI lwwAPI
<$> newTVarIO rk
<$> newTVarIO Nothing
<*> newTVarIO Nothing
<*> newTVarIO defSegmentSize
<*> newTVarIO defCompressionLevel
@ -307,15 +354,7 @@ recover m = fix \again -> do
liftIO $ withGit3Env connected do
mf <- getRepoManifest
let reflog = lastMay [ x
| ListVal [SymbolVal "reflog", SignPubKeyLike x] <- mf
]
ask >>= \case
Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog
_ -> none
updateRepoKey rk
ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed

11
miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs
View File

@ -29,6 +29,7 @@ module Data.Config.Suckless.Syntax
, pattern LitBoolVal
, pattern LitScientificVal
, pattern StringLike
, pattern TextLike
, pattern StringLikeList
, pattern Nil
, pattern OpaqueVal
@ -88,15 +89,23 @@ stringLike = \case
SymbolVal (Id s) -> Just $ Text.unpack s
x -> Just $ show $ pretty x
textLike :: Syntax c -> Maybe Text
textLike = \case
LitStrVal s -> Just s
SymbolVal (Id s) -> Just s
x -> Just $ Text.pack $ show $ pretty x
stringLikeList :: [Syntax c] -> [String]
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString
pattern StringLike :: forall {c} . String -> Syntax c
pattern StringLike e <- (stringLike -> Just e)
pattern TextLike :: forall {c} . Text -> Syntax c
pattern TextLike e <- (textLike -> Just e)
pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
pattern StringLikeList e <- (stringLikeList -> e)