wip, updateRepoHead

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -94,6 +94,7 @@ data GroupKeyIdScheme = GroupKeyIdBasic1 -- encrypt zeroes then hash
 
 newtype GroupKeyId = GroupKeyId N.ByteString
                      deriving stock (Eq,Ord,Generic,Show)
+                     deriving newtype Hashable
 
 instance Pretty GroupKeyId where
   pretty what = pretty (AsBase58 (coerce @_ @N.ByteString what))

hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs

@@ -6,7 +6,12 @@ import HBS2.Git3.Prelude
 import HBS2.Git3.State
 import HBS2.Git3.Repo.Types
 
+import HBS2.Data.Detect
 import HBS2.System.Dir
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.CLI.Run.MetaData
+import HBS2.Net.Auth.Credentials
+import HBS2.KeyMan.Keys.Direct
 
 import HBS2.Git.Local.CLI
 
@@ -18,12 +23,14 @@ import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString.Lazy qualified as LBS
 import Data.Either
 import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Data.Maybe
 import Data.Text qualified as Text
 import Data.Word
 import Lens.Micro.Platform
 import System.Random hiding (next)
 
+import Streaming.Prelude qualified as S
 
 {- HLINT ignore "Functor law" -}
 
@@ -81,4 +88,107 @@ newRemoteName key = do
     if not (HM.member name refs) then pure name
     else again (succ <$> ( i <|> Just 0) )
 
+updateRepoHead :: (HBS2GitPerks m)
+               => GitRepoKey
+               -> [Syntax C]
+               -> [HashRef]
+               -> Git3 m ()
+updateRepoHead repo manifest gkRefs' = do
+
+  sto <- getStorage
+  lwwAPI <- getClientAPI @LWWRefAPI @UNIX
+
+  creds <- liftIO $ runKeymanClientRO (loadCredentials repo)
+               >>= orThrow GitRepoNoAccess
+
+  let (wsk, wpk) = (view peerSignSk creds, view peerSignPk creds)
+
+  let mfs = vcat $ fmap pretty manifest
+  manifestTree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show mfs))
+                     >>= orThrowPassIO
+
+  LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty
+
+  repoHead <- readLogThrow (getBlock sto) lwwValue
+
+  oldKeys <- fromMaybe mempty <$> runMaybeT do
+               h <- headMay (tailSafe repoHead) & toMPlus
+               readLogThrow (getBlock sto) h
+
+
+  let gkRefs = HS.toList $ HS.fromList (gkRefs' <> oldKeys)
+
+  gkTree <- if null gkRefs
+              then pure Nothing
+              else do
+                tree <- makeMerkle 0 (toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) gkRefs)
+                           (\(_,_,bs) -> void $ putBlock sto bs)
+                pure $ Just (HashRef tree)
+
+  let refs = manifestTree : maybeToList gkTree
+
+  blk <- makeMerkle 0 (toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) refs)
+         (\(_,_,bs) -> void $ putBlock sto bs)
+
+  now <- liftIO getPOSIXTime <&> round
+  let box = makeSignedBox wpk wsk (LWWRef now (coerce blk) Nothing)
+
+  callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box
+    >>= orThrow RpcTimeout
+
+updateGroupKey :: HBS2GitPerks m => GitRepoKey -> HashRef -> Git3 m ()
+updateGroupKey repo new = do
+  waitRepo (Just 10) repo
+  sto <- getStorage
+  LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty
+  RepoManifest manifest <- getRepoManifest
+  deps <- readLogThrow (getBlock sto) (coerce lwwValue)
+
+  gkNew <- loadGroupKeyMaybe @HBS2Basic sto new
+              >>= orThrow  (GitRepoNoGroupKey new)
+
+  flip runContT pure do
+
+    gkth <- ContT $ maybe1 (headMay (tailSafe deps)) none
+    gkTree <- readLogThrow (getBlock sto) gkth
+
+    r <- newTVarIO mempty
+    lift $ for_ gkTree $ \gh -> void $ runMaybeT do
+      gk <- loadGroupKeyMaybe @HBS2Basic sto gh >>= toMPlus
+      gkId <- groupKeyId gk & toMPlus
+      liftIO $ print $ "gk" <+> pretty gh <+> pretty gkId
+
+      let missed = HM.keysSet $ recipients gkNew `HM.difference` recipients gk
+
+      unless (HS.null missed) do
+        atomically $ modifyTVar r (HM.insert gkId (gk,missed))
+        none
+
+    keys <- readTVarIO r <&> HM.elems
+
+    oldKeys <- liftIO $ runKeymanClientRO do
+      for keys $ \(gk, missed) -> do
+        -- FIXME: what-if-no-access?
+        --   предполагается, что это делает owner.
+        --   owner имеет все ключи.
+        --   но это может сделать и чел, который просто имеет все ключи,
+        --   но нет, т.к. он не сможет записать lwwref
+        gks <- extractGroupKeySecret gk >>= orThrow GitRepoNoAccess
+        gkNew <- generateGroupKey @'HBS2Basic (Just gks) (HS.toList missed)
+        writeAsMerkle sto (serialise gkNew) <&> HashRef
+
+    let newKeys = HS.toList $ HS.fromList ( new : oldKeys )
+
+    for_ newKeys $ \k -> do
+      liftIO $ print $ "new gk" <+> pretty k
+
+    --
+    let newManifest0 = flip mapMaybe manifest $ \case
+                        ListVal [StringLike "gk", HashLike x]  -> Nothing
+                        x ->  Just x
+    let newManifest = newManifest0 <> [ mkForm "gk" [ mkSym (show $ pretty new) ] ]
+
+    lift do
+      updateRepoHead repo newManifest newKeys
+      updateRepoKey repo
 

hbs2-git3/lib/HBS2/Git3/Run.hs

@@ -4,7 +4,7 @@ import HBS2.Git3.Prelude
 import HBS2.Data.Log.Structured
 
 import HBS2.CLI.Run.Internal.Merkle (getTreeContents)
-
+import HBS2.Data.Detect hiding (Blob)
 import HBS2.System.Dir
 
 import HBS2.Git3.Git
@@ -251,7 +251,9 @@ compression      ;  prints compression level
             let f = makeRelative cur f'
             liftIO $ print $ fill 10 (pretty s) <+> pretty f
 
-        entry $ bindMatch "reflog:index:list:tx" $ nil_ $ const $ lift $ connectedDo do
+        entry $ bindMatch "reflog:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do
+          resolveRepoKeyThrow syn >>= setGitRepoKey
+          waitRepo Nothing =<< getGitRepoKeyThrow
           r <- newIORef  ( mempty :: HashSet HashRef )
           index <- openIndex
           enumEntries index $ \bs -> do
@@ -315,6 +317,7 @@ compression      ;  prints compression level
           let (opts,argz) = splitOpts [] syn
 
           let what = headDef "HEAD" [ x | StringLike x <- argz ]
+
           h0  <- gitRevParseThrow what
 
           no_ <- newTVarIO 0
@@ -360,16 +363,16 @@ compression      ;  prints compression level
 
         entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do
 
-          resolveRepoKeyThrow syn >>= setGitRepoKey
+          let (opts, argz) = splitOpts [ ("--checkpoints",0)
-          waitRepo Nothing =<< getGitRepoKeyThrow
-
-          let (opts, _) = splitOpts [ ("--checkpoints",0)
                                     , ("--segments",0)
                                     ] syn
 
           let cpOnly   = or [ True | ListVal [StringLike "--checkpoints"] <- opts ]
           let sOnly    = or [ True | ListVal [StringLike "--segments"] <- opts ]
 
+          resolveRepoKeyThrow argz >>= setGitRepoKey
+          waitRepo Nothing =<< getGitRepoKeyThrow
+
           hxs <- txListAll Nothing
 
           liftIO $ forM_ hxs $ \(h,tx) -> do
@@ -413,11 +416,13 @@ compression      ;  prints compression level
 
         entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do
           resolveRepoKeyThrow syn >>= setGitRepoKey
+          waitRepo Nothing =<< getGitRepoKeyThrow
           p <- importedCheckpoint
           liftIO $ print $ pretty p
 
         entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
           resolveRepoKeyThrow syn >>= setGitRepoKey
+          waitRepo Nothing =<< getGitRepoKeyThrow
           importGitRefLog
 
         brief "shows repo manifest" $
@@ -447,13 +452,46 @@ compression      ;  prints compression level
           for_ gk' $ \(gkh, _) -> do
             liftIO $ print $ pretty $ mkForm @C "gk" [ mkSym (show $ pretty gkh) ]
 
+        brief "updates group key for repo" $
+          args [arg "string" "repo", arg "hash" "group-key-hash" ]  $
+          entry $ bindMatch "repo:gk:update" $ nil_ $ \case
+            [ x@(StringLike{}), HashLike h ] -> lift $ connectedDo do
+              repo <- resolveRepoKeyThrow [x]
+              updateGroupKey repo h
+
+            _ -> throwIO $ BadFormException @C nil
+
+        entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do
+          resolveRepoKeyThrow syn >>= setGitRepoKey
+          waitRepo Nothing =<< getGitRepoKeyThrow
+
+          ref <- getGitRepoKeyThrow
+
+          lwwAPI <- getClientAPI @LWWRefAPI @UNIX
+
+          sto <- getStorage
+
+          runMaybeT do
+
+            LWWRef{..} <- liftIO (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (coerce ref))
+                             >>= orThrow RpcTimeout
+                            >>= toMPlus
+
+            hrefs <- lift $ readLogThrow (getBlock sto) lwwValue
+
+            journal <- headMay (tail hrefs) & toMPlus
+
+            keys <- lift $ readLogThrow (getBlock sto) journal
+
+            liftIO $ for_ keys $ \k -> do
+              liftIO $ print $ pretty k
+
         entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
             Repo.initRepo syn
 
         entry $ bindMatch "repo:relay-only" $ nil_ $ \case
           [ SignPubKeyLike repo ] -> lift $ connectedDo do
             setGitRepoKey repo
-
             waitRepo (Just 2) =<< getGitRepoKeyThrow
 
           _ -> throwIO (BadFormException @C nil)
@@ -461,4 +499,3 @@ compression      ;  prints compression level
         exportEntries "reflog:"
 
 
-

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

@@ -46,7 +46,7 @@ readLocalConf = do
       <&> parseTop
       >>= either (const $ pure mempty) pure
 
-data HBS2GitExcepion =
+data HBS2GitException =
     RefLogNotSet
   | GitRepoRefNotSet
   | GitRepoRefEmpty
@@ -60,9 +60,11 @@ data HBS2GitExcepion =
   | NoGitDir
   | GitRemoteKeyNotResolved String
   | GitCantGenerateRemoteName
+  | GitRepoNoGroupKey HashRef
+  | GitRepoNoAccess
   deriving stock (Show,Typeable)
 
-instance Exception HBS2GitExcepion
+instance Exception HBS2GitException
 
 defSegmentSize :: Int
 defSegmentSize = 50 * 1024 * 1024

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs

@@ -12,6 +12,7 @@ import HBS2.KeyMan.State
 
 import HBS2.Prelude
 import HBS2.Base58
+import HBS2.Storage
 
 -- FIXME: remove-this
 import HBS2.Net.Auth.Credentials()
@@ -27,10 +28,18 @@ import Prettyprinter
 import Lens.Micro.Platform
 import UnliftIO
 
+data StorageNotBound =
+  StorageNotBound
+  deriving stock (Show, Typeable)
+
+instance Exception StorageNotBound
+
+
 data AppEnv =
   AppEnv
   { appConf :: [Syntax C]
   , appDb   :: DBPipeEnv
+  , appSto  :: TVar (Maybe AnyStorage)
   }
 
 newtype KeyManCLI m a = KeyManCLI { fromKeyManCLI :: ReaderT AppEnv m a }
@@ -48,6 +57,7 @@ newAppEnv = do
   let dbOpts = dbPipeOptsDef
   AppEnv <$> readConfig
          <*> (getStatePath >>= newDBPipeEnv dbOpts)
+         <*> newTVarIO Nothing
 
 runApp :: MonadUnliftIO m => KeyManCLI m () -> m ()
 runApp action = do
@@ -92,4 +102,11 @@ instance MonadIO m => HasConf (ReaderT AppEnv m) where
 instance MonadIO m => HasConf (KeyManCLI m) where
   getConf = asks appConf
 
+-- instance MonadIO m => HasStorage (KeyManCLI m) where
+--   getStorage = do
+--     msto <- asks appSto >>= readTVarIO
+--     case msto of
+--       Just x -> pure x
+--       Nothing -> do
+--         throwIO StorageNotBound
 

hbs2-keyman/hbs2-keyman/Main.hs

@@ -1,3 +1,5 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
 module Main where
 
 import HBS2.KeyMan.Prelude
@@ -5,7 +7,9 @@ import HBS2.KeyMan.App.Types
 import HBS2.KeyMan.Config
 import HBS2.KeyMan.State
 
+import HBS2.OrDie
 import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.GroupKeySymm
 
 import HBS2.Data.KeyRing qualified as KeyRing
 
@@ -42,6 +46,7 @@ import Control.Monad.Reader
 import Control.Monad.Except
 import Codec.Serialise
 import Data.Coerce
+import System.Exit (exitSuccess)
 
 import Streaming.Prelude qualified as S
 
@@ -55,7 +60,12 @@ type Command m = m ()
 globalOptions :: Parser GlobalOptions
 globalOptions = pure GlobalOptions
 
-type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic)
+type AppPerks m = ( MonadIO m
+                  , MonadUnliftIO m
+                  , MonadReader AppEnv m
+                  , HasConf m
+                  , SerialisedCredentials 'HBS2Basic
+                  )
 
 -- TODO: key-mamagement-command-about-to-move-here
 
@@ -67,6 +77,7 @@ commands = hsubparser
   <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key"))
   <> command "add-mask"   (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'"))
   <> command "config"     (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config"))
+  <> command "run"        (O.info (runScript <**> helper) (progDesc "run command"))
   )
 
 opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
@@ -75,6 +86,79 @@ opts = O.info (liftA2 (,) globalOptions commands <**> helper)
  <> header "hbs2-keyman" )
 
 
+quit :: MonadIO m => m ()
+quit = liftIO exitSuccess
+
+theDict :: forall m . ( AppPerks m
+                      ) => AnyStorage -> Dict C m
+
+theDict sto = do
+  makeDict @C do
+    -- TODO: write-man-entries
+    myHelpEntry
+    myEntries
+
+    -- entry $ bindValue "internal:storage" $ mkOpaque (22 ::Int )
+
+  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 "stdin" $ nil_  $ const do
+
+          co <- liftIO getContents
+                   <&> parseTop
+                   >>= either (error.show) pure
+
+          lift $ run (theDict sto) co
+
+        entry $ bindMatch "gk:track" $ nil_  $ \case
+          [HashLike gkhash] -> lift do
+
+            runMaybeT do
+              gk <- loadGroupKeyMaybe @'HBS2Basic sto gkhash
+                      >>= toMPlus
+
+              gkId <- groupKeyId gk & toMPlus
+
+              -- notice $ "fuck?"
+              lift $ withState  $ transactional do
+                insertGKTrack gkId gkhash
+                insertGKAccess gkhash gk
+
+              liftIO $ print $ pretty $ mkForm @C "gk:added" [mkSym (show $ pretty gkhash)]
+
+          _ -> throwIO (BadFormException @C nil)
+
+
+runScript :: (AppPerks m, MonadReader AppEnv m) => Parser (Command m)
+runScript = do
+  argz <- some (argument str (metavar "TERM"))
+  pure do
+
+    AppEnv{..} <- ask
+
+    flip runContT pure do
+      so' <- detectRPC
+      so <- ContT $ maybe1 so' (err $ red "peer is down")
+      sto <- ContT (withRPC2 @StorageAPI so) <&> AnyStorage . StorageClient
+      atomically $ writeTVar appSto(Just sto)
+
+      cli <- parseTop (unlines $ unwords <$> splitForms argz)
+             & either  (error.show) pure
+
+      lift $ run (theDict sto) cli >>= display
+
 showConfig :: (AppPerks m) => Parser (Command m)
 showConfig = do
   pure do
@@ -242,7 +326,6 @@ updateKeys = do
           commitAll
 
 
-
 setWeightCmd :: (AppPerks m) => Parser (Command m)
 setWeightCmd = do
   k <- argument str (metavar "KEY" <> help "Key identifier")