wip

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
+  entry $ bindMatch "r:list" $ nil_ $ const $ lift $ connectedDo do
-    importGitRefLog
+      reflog <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed
 
-    rrefs <- importedRefs
+      notice $ red "REFLOG" <+> pretty (AsBase58 reflog)
 
-    for_ rrefs $ \(r,h) -> do
+      importGitRefLog
-      debug $ pretty h <+> pretty r
-      sendLine $ show $ pretty h <+> pretty r
 
-    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)
 

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
 
 

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)
+                  let payload = LBS.toStrict $ serialise (AnnotatedHashRef Nothing href)
-                  tx <- mkRefLogUpdateFrom (coerce reflog) payload
+                  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
+                                 -- , HasStorage m1
-                                 , HasClientAPI RefLogAPI UNIX m1
+                                 -- , HasClientAPI RefLogAPI UNIX m1
-                                 , HasGitRemoteKey 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))
+         let payload = LBS.toStrict $ serialise (SequentialRef t0 (AnnotatedHashRef Nothing cp))
-         tx <- mkRefLogUpdateFrom (coerce reflog) payload
+         tx <- genRefLogUpdate payload
 
          callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) api tx
            >>= orThrow ExportWriteTimeout

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")
 

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)

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
+          updateRepoKey rk
-
-          let reflog = lastMay [ x
-                               | ListVal [SymbolVal "reflog", SignPubKeyLike x]  <- mf
-                               ]
-
-          ask >>= \case
-                Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog
-                _ -> none
 
           ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed
 

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)