mirror of https://github.com/voidlizard/hbs2
wip, updateRepoHead
This commit is contained in:
voidlizard
parent
f7aa86a647
commit
d993501b1f
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
waitRepo Nothing =<< getGitRepoKeyThrow
|
||||
|
||||
let (opts, _) = splitOpts [ ("--checkpoints",0)
|
||||
let (opts, argz) = 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:"
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue