From 3d27321241949c9db8e3153b7a921cfc9490abc5 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Sun, 19 Jan 2025 20:51:46 +0300 Subject: [PATCH] wip --- hbs2-git3/app/GitRemoteHelper.hs | 48 +++++++++++---- hbs2-git3/lib/HBS2/Git3/Config/Local.hs | 6 +- hbs2-git3/lib/HBS2/Git3/Export.hs | 24 +++++--- hbs2-git3/lib/HBS2/Git3/Import.hs | 2 +- hbs2-git3/lib/HBS2/Git3/Run.hs | 18 +++--- .../lib/HBS2/Git3/State/Internal/Types.hs | 61 +++++++++++++++---- .../lib/Data/Config/Suckless/Syntax.hs | 11 +++- 7 files changed, 127 insertions(+), 43 deletions(-) diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 5d6c54d1..649f12b8 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -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) diff --git a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs index 37a250b4..534f0243 100644 --- a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs +++ b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/Export.hs b/hbs2-git3/lib/HBS2/Git3/Export.hs index 4a132f53..f355a920 100644 --- a/hbs2-git3/lib/HBS2/Git3/Export.hs +++ b/hbs2-git3/lib/HBS2/Git3/Export.hs @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 84996feb..36a6feee 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -118,7 +118,7 @@ importGitRefLog = do updateReflogIndex - packs <- findGitDir + packs <- gitDir >>= orThrowUser "git directory not found" <&> ( "objects/pack") diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index fc3888a2..ad87519a 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -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) diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index 18bb7e9f..5a3e5bc1 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -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 diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index e04a1abb..10c4f114 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -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)