mirror of https://github.com/voidlizard/hbs2
massive type rafactoring
This commit is contained in:
Dmitry Zuikov
parent
5effcebfee
commit
ba7cc35bbc
|
|
@ -70,7 +70,7 @@ data DefStateOpt
|
|||
data StateRefOpt
|
||||
|
||||
data QBLFRefKey
|
||||
type MyRefKey = AnyRefKey QBLFRefKey HBS2Basic
|
||||
type MyRefKey = AnyRefKey QBLFRefKey 'HBS2Basic
|
||||
|
||||
instance Monad m => HasCfgKey HttpPortOpt (Maybe Int) m where
|
||||
key = "http"
|
||||
|
|
@ -98,8 +98,8 @@ instance Monad m => HasCfgKey DefStateOpt (Maybe String) m where
|
|||
instance Monad m => HasCfgKey StateRefOpt (Maybe String) m where
|
||||
key = "state-ref"
|
||||
|
||||
class ToBalance e tx where
|
||||
toBalance :: tx -> [(Account e, Amount)]
|
||||
class ToBalance s tx where
|
||||
toBalance :: tx -> [(Account s, Amount)]
|
||||
|
||||
tracePrefix :: SetLoggerEntry
|
||||
tracePrefix = toStderr . logPrefix "[trace] "
|
||||
|
|
@ -153,7 +153,7 @@ data MyEnv =
|
|||
, myChan :: RefChanId UNIX
|
||||
, myRef :: MyRefKey
|
||||
, mySto :: AnyStorage
|
||||
, myCred :: PeerCredentials HBS2Basic
|
||||
, myCred :: PeerCredentials 'HBS2Basic
|
||||
, myHttpPort :: Int
|
||||
, myFetch :: Cache HashRef ()
|
||||
}
|
||||
|
|
@ -211,8 +211,8 @@ instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (App m) where
|
|||
tryLockForPeriod _ _ = pure True
|
||||
|
||||
instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) where
|
||||
type QBLFActor ConsensusQBLF = Actor L4Proto
|
||||
type QBLFTransaction ConsensusQBLF = QBLFDemoToken L4Proto
|
||||
type QBLFActor ConsensusQBLF = Actor 'HBS2Basic
|
||||
type QBLFTransaction ConsensusQBLF = QBLFDemoToken 'HBS2Basic
|
||||
type QBLFState ConsensusQBLF = DAppState
|
||||
|
||||
qblfMoveForward _ s1 = do
|
||||
|
|
@ -247,7 +247,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
-- пробуем разослать бандлы с транзакциями
|
||||
runMaybeT do
|
||||
ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
|
||||
let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref)
|
||||
let refval = makeBundleRefValue @'HBS2Basic pk sk (BundleRefSimple ref)
|
||||
r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
|
||||
lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
|
||||
|
||||
|
|
@ -280,7 +280,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
let sk = view peerSignSk creds
|
||||
let pk = view peerSignPk creds
|
||||
nonce <- randomIO @Word64 <&> serialise <&> LBS.toStrict
|
||||
let box = makeSignedBox @UNIX pk sk (LBS.toStrict (serialise msg) <> nonce)
|
||||
let box = makeSignedBox pk sk (LBS.toStrict (serialise msg) <> nonce)
|
||||
let notify = Notify @UNIX chan box
|
||||
request self notify
|
||||
|
||||
|
|
@ -327,17 +327,17 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
|
||||
bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t)
|
||||
|
||||
tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) bs & either (const Nothing) Just
|
||||
tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bs & either (const Nothing) Just
|
||||
|
||||
case tx of
|
||||
Emit box -> do
|
||||
(pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box
|
||||
(pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box
|
||||
guard ( chan == pk )
|
||||
debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
|
||||
pure ([(t,e)], mempty)
|
||||
|
||||
(Move box) -> do
|
||||
(_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box
|
||||
(_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx 'HBS2Basic) box
|
||||
|
||||
guard (qty > 0)
|
||||
debug $ "MOVE TRANSACTION" <+> pretty t
|
||||
|
|
@ -352,7 +352,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
bal0 <- balances (fromDAppState s0)
|
||||
|
||||
-- баланс с учётом новых emit
|
||||
let balE = foldMap (toBalance @L4Proto . snd) emits
|
||||
let balE = foldMap (toBalance @'HBS2Basic. snd) emits
|
||||
& HashMap.fromListWith (+)
|
||||
& HashMap.unionWith (+) bal0
|
||||
|
||||
|
|
@ -391,12 +391,12 @@ balances :: forall e s m . ( e ~ L4Proto
|
|||
, HasStorage m
|
||||
-- , FromStringMaybe (PubKey 'Sign s)
|
||||
, s ~ Encryption e
|
||||
, ToBalance L4Proto (EmitTx L4Proto)
|
||||
, ToBalance L4Proto (MoveTx L4Proto)
|
||||
, ToBalance s (EmitTx s)
|
||||
, ToBalance s (MoveTx s)
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
)
|
||||
=> HashRef
|
||||
-> m (HashMap (Account e) Amount)
|
||||
-> m (HashMap (Account s) Amount)
|
||||
|
||||
balances root = do
|
||||
sto <- getStorage
|
||||
|
|
@ -406,7 +406,7 @@ balances root = do
|
|||
cached <- runMaybeT do
|
||||
rval <- MaybeT $ liftIO $ getRef sto pk
|
||||
val <- MaybeT $ liftIO $ getBlock sto rval
|
||||
MaybeT $ deserialiseOrFail @(HashMap (Account e) Amount) val
|
||||
MaybeT $ deserialiseOrFail @(HashMap (Account s) Amount) val
|
||||
& either (const $ pure Nothing) (pure . Just)
|
||||
|
||||
case cached of
|
||||
|
|
@ -417,16 +417,16 @@ balances root = do
|
|||
|
||||
r <- forM txs $ \h -> runMaybeT do
|
||||
blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h)
|
||||
tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) blk & either (const Nothing) Just
|
||||
tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken s) blk & either (const Nothing) Just
|
||||
|
||||
case tx of
|
||||
Emit box -> do
|
||||
(_, emit) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box
|
||||
pure $ toBalance @e emit
|
||||
(_, emit) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx s) box
|
||||
pure $ toBalance @s emit
|
||||
|
||||
Move box -> do
|
||||
(_, move) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box
|
||||
pure $ toBalance @e move
|
||||
(_, move) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx s) box
|
||||
pure $ toBalance @s move
|
||||
|
||||
let val = catMaybes r & mconcat & HashMap.fromListWith (+)
|
||||
|
||||
|
|
@ -450,8 +450,8 @@ balances root = do
|
|||
-- -> [(tx, b)]
|
||||
-- -> [(tx, b)]
|
||||
|
||||
updBalances :: forall e a tx . (ForRefChans e, ToBalance e tx)
|
||||
=> HashMap (Account e) Amount
|
||||
updBalances :: forall e s a tx . (ForRefChans e, ToBalance s tx, s ~ Encryption e)
|
||||
=> HashMap (Account s) Amount
|
||||
-> [(a, tx)]
|
||||
-> [(a, tx)]
|
||||
|
||||
|
|
@ -467,7 +467,7 @@ updBalances = go
|
|||
go bal rest
|
||||
|
||||
where
|
||||
nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @e (snd t)))
|
||||
nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @s (snd t)))
|
||||
good = HashMap.filter (<0) nb & HashMap.null
|
||||
|
||||
|
||||
|
|
@ -515,7 +515,7 @@ runMe conf = withLogging $ flip runReaderT conf do
|
|||
) `orDie` "state-ref not set"
|
||||
|
||||
sc <- liftIO $ BS.readFile kr
|
||||
creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
|
||||
chan <- pure (fromStringMay @(RefChanId L4Proto) chan') `orDie` "invalid REFCHAN"
|
||||
|
||||
|
|
@ -560,11 +560,11 @@ runMe conf = withLogging $ flip runReaderT conf do
|
|||
|
||||
headBlk <- getRefChanHead @L4Proto sto (RefChanHeadKey chan) `orDie` "can't read head block"
|
||||
|
||||
let self = view peerSignPk creds & Actor @L4Proto
|
||||
let self = view peerSignPk creds & Actor
|
||||
|
||||
let actors = view refChanHeadAuthors headBlk
|
||||
& HashSet.toList
|
||||
& fmap (Actor @L4Proto)
|
||||
& fmap Actor
|
||||
|
||||
runApp myEnv do
|
||||
|
||||
|
|
@ -590,7 +590,7 @@ runMe conf = withLogging $ flip runReaderT conf do
|
|||
|
||||
debug $ "GOT TX" <+> pretty hBin
|
||||
|
||||
tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken L4Proto) bin)
|
||||
tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bin)
|
||||
|
||||
tx <- case tok of
|
||||
(Emit box) -> do
|
||||
|
|
@ -649,7 +649,7 @@ runMe conf = withLogging $ flip runReaderT conf do
|
|||
|
||||
let coco = hashObject @HbSync $ serialise msg
|
||||
void $ runMaybeT do
|
||||
(_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 @ByteString @UNIX msg
|
||||
(_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 msg
|
||||
qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
|
||||
& either (const Nothing) Just
|
||||
|
||||
|
|
@ -729,11 +729,11 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
dest <- strArgument ( metavar "ADDRESS" )
|
||||
pure $ const $ silently do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
|
||||
tx <- makeEmitTx @L4Proto pk sk acc amnt
|
||||
tx <- makeEmitTx @_ @L4Proto pk sk acc amnt
|
||||
LBS.putStr $ serialise tx
|
||||
|
||||
pGenMove = do
|
||||
|
|
@ -742,29 +742,29 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
dest <- strArgument ( metavar "ADDRESS" )
|
||||
pure $ const $ silently do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
|
||||
tx <- makeMoveTx @L4Proto pk sk acc amnt
|
||||
tx <- makeMoveTx @_ @L4Proto pk sk acc amnt
|
||||
LBS.putStr $ serialise tx
|
||||
|
||||
pCheckTx = do
|
||||
kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" )
|
||||
pure $ const do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
|
||||
tx <- LBS.getContents <&> deserialise @(QBLFDemoToken L4Proto)
|
||||
tx <- LBS.getContents <&> deserialise @(QBLFDemoToken 'HBS2Basic)
|
||||
|
||||
case tx of
|
||||
Emit box -> do
|
||||
void $ pure (unboxSignedBox0 @(EmitTx L4Proto) @L4Proto box) `orDie` "bad emit tx"
|
||||
void $ pure (unboxSignedBox0 box) `orDie` "bad emit tx"
|
||||
|
||||
Move box -> do
|
||||
void $ pure (unboxSignedBox0 @(MoveTx L4Proto) @L4Proto box) `orDie` "bad move tx"
|
||||
void $ pure (unboxSignedBox0 box) `orDie` "bad move tx"
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language TypeOperators #-}
|
||||
module Demo.QBLF.Transactions where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
|
|
@ -16,17 +18,17 @@ import Data.ByteString.Lazy (ByteString)
|
|||
import Data.Word (Word64)
|
||||
import System.Random
|
||||
|
||||
newtype Actor e =
|
||||
Actor { fromActor :: PubKey 'Sign (Encryption e) }
|
||||
newtype Actor s =
|
||||
Actor { fromActor :: PubKey 'Sign s }
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving stock instance Eq (PubKey 'Sign (Encryption e)) => Eq (Actor e)
|
||||
deriving newtype instance Hashable (PubKey 'Sign (Encryption e)) => Hashable (Actor e)
|
||||
deriving stock instance Eq (PubKey 'Sign s) => Eq (Actor s)
|
||||
deriving newtype instance Hashable (PubKey 'Sign s) => Hashable (Actor s)
|
||||
|
||||
instance Pretty (AsBase58 (PubKey 'Sign (Encryption e))) => Pretty (Actor e) where
|
||||
instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (Actor s) where
|
||||
pretty (Actor a) = pretty (AsBase58 a)
|
||||
|
||||
type Account e = PubKey 'Sign (Encryption e)
|
||||
type Account s = PubKey 'Sign s
|
||||
|
||||
newtype Amount = Amount Integer
|
||||
deriving stock (Eq,Show,Ord,Data,Generic)
|
||||
|
|
@ -39,48 +41,48 @@ newtype DAppState = DAppState { fromDAppState :: HashRef }
|
|||
instance Hashed HbSync DAppState where
|
||||
hashObject (DAppState (HashRef h)) = h
|
||||
|
||||
data EmitTx e = EmitTx (Account e) Amount Word64
|
||||
data EmitTx s = EmitTx (Account s) Amount Word64
|
||||
deriving stock (Generic)
|
||||
|
||||
data MoveTx e = MoveTx (Account e) (Account e) Amount Word64
|
||||
data MoveTx s = MoveTx (Account s) (Account s) Amount Word64
|
||||
deriving stock (Generic)
|
||||
|
||||
data QBLFDemoToken e =
|
||||
Emit (SignedBox (EmitTx e) e) -- proof: owner's key
|
||||
| Move (SignedBox (MoveTx e) e) -- proof: wallet's key
|
||||
data QBLFDemoToken s =
|
||||
Emit (SignedBox (EmitTx s) s) -- proof: owner's key
|
||||
| Move (SignedBox (MoveTx s) s) -- proof: wallet's key
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForRefChans e => Serialise (Actor e)
|
||||
instance ForQBLFDemoToken s => Serialise (Actor s)
|
||||
|
||||
instance Serialise DAppState
|
||||
|
||||
instance Serialise Amount
|
||||
|
||||
instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (EmitTx e)
|
||||
instance ForQBLFDemoToken s => Serialise (EmitTx s)
|
||||
|
||||
instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (MoveTx e)
|
||||
instance ForQBLFDemoToken s => Serialise (MoveTx s)
|
||||
|
||||
instance (Serialise (Account e), ForRefChans e) => Serialise (QBLFDemoToken e)
|
||||
instance ForQBLFDemoToken s => Serialise (QBLFDemoToken s)
|
||||
|
||||
type ForQBLFDemoToken e = ( Eq (PubKey 'Sign (Encryption e))
|
||||
, Eq (Signature (Encryption e))
|
||||
, Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
|
||||
, ForSignedBox e
|
||||
, FromStringMaybe (PubKey 'Sign (Encryption e))
|
||||
, Serialise (PubKey 'Sign (Encryption e))
|
||||
, Serialise (Signature (Encryption e))
|
||||
, Hashable (PubKey 'Sign (Encryption e))
|
||||
type ForQBLFDemoToken s = ( Eq (PubKey 'Sign s)
|
||||
, Eq (Signature s)
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, ForSignedBox s
|
||||
, FromStringMaybe (PubKey 'Sign s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (Signature s)
|
||||
, Hashable (PubKey 'Sign s)
|
||||
)
|
||||
|
||||
deriving stock instance (ForQBLFDemoToken e) => Eq (QBLFDemoToken e)
|
||||
deriving stock instance (ForQBLFDemoToken s) => Eq (QBLFDemoToken s)
|
||||
|
||||
instance ForQBLFDemoToken e => Hashable (QBLFDemoToken e) where
|
||||
instance ForQBLFDemoToken s => Hashable (QBLFDemoToken s) where
|
||||
hashWithSalt salt = \case
|
||||
Emit box -> hashWithSalt salt box
|
||||
Move box -> hashWithSalt salt box
|
||||
|
||||
newtype QBLFDemoTran e =
|
||||
QBLFDemoTran (SignedBox (QBLFDemoToken e) e)
|
||||
QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e))
|
||||
deriving stock Generic
|
||||
|
||||
instance ForRefChans e => Serialise (QBLFDemoTran e)
|
||||
|
|
@ -93,39 +95,43 @@ deriving newtype instance
|
|||
(Eq (Signature (Encryption e)), ForRefChans e)
|
||||
=> Hashable (QBLFDemoTran e)
|
||||
|
||||
instance Serialise (QBLFDemoTran UNIX) => HasProtocol UNIX (QBLFDemoTran UNIX) where
|
||||
instance HasProtocol UNIX (QBLFDemoTran UNIX) where
|
||||
type instance ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
|
||||
type instance Encoded UNIX = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
makeEmitTx :: forall e m . ( MonadIO m
|
||||
, ForRefChans e
|
||||
, Signatures (Encryption e)
|
||||
)
|
||||
=> PubKey 'Sign (Encryption e)
|
||||
-> PrivKey 'Sign (Encryption e)
|
||||
-> Account e
|
||||
makeEmitTx :: forall s e m . ( MonadIO m
|
||||
, ForRefChans e
|
||||
, ForQBLFDemoToken s
|
||||
, Signatures (Encryption e)
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> PubKey 'Sign s
|
||||
-> PrivKey 'Sign s
|
||||
-> Account s
|
||||
-> Amount
|
||||
-> m (QBLFDemoToken e)
|
||||
-> m (QBLFDemoToken s)
|
||||
|
||||
makeEmitTx pk sk acc amount = do
|
||||
nonce <- randomIO
|
||||
let box = makeSignedBox @e pk sk (EmitTx @e acc amount nonce)
|
||||
pure (Emit @e box)
|
||||
let box = makeSignedBox @s pk sk (EmitTx acc amount nonce)
|
||||
pure (Emit @s box)
|
||||
|
||||
makeMoveTx :: forall e m . ( MonadIO m
|
||||
, ForRefChans e
|
||||
, Signatures (Encryption e)
|
||||
)
|
||||
=> PubKey 'Sign (Encryption e) -- from pk
|
||||
-> PrivKey 'Sign (Encryption e) -- from sk
|
||||
-> Account e
|
||||
makeMoveTx :: forall s e m . ( MonadIO m
|
||||
, ForQBLFDemoToken s
|
||||
, ForRefChans e
|
||||
, Signatures s
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> PubKey 'Sign s -- from pk
|
||||
-> PrivKey 'Sign s -- from sk
|
||||
-> Account s
|
||||
-> Amount -- amount
|
||||
-> m (QBLFDemoToken e)
|
||||
-> m (QBLFDemoToken s)
|
||||
|
||||
makeMoveTx pk sk acc amount = do
|
||||
nonce <- randomIO
|
||||
let box = makeSignedBox @e pk sk (MoveTx @e pk acc amount nonce)
|
||||
pure (Move @e box)
|
||||
let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce)
|
||||
pure (Move @s box)
|
||||
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ import Streaming()
|
|||
|
||||
{- HLINT ignore "Use newtype instead of data" -}
|
||||
|
||||
data BundleRefValue e =
|
||||
BundleRefValue (SignedBox BundleRef e)
|
||||
data BundleRefValue s =
|
||||
BundleRefValue (SignedBox BundleRef s)
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForSignedBox e => Serialise (BundleRefValue e)
|
||||
|
|
@ -39,13 +39,13 @@ data BundleRef =
|
|||
instance Serialise BundleRef
|
||||
|
||||
|
||||
makeBundleRefValue :: forall e . (ForSignedBox e, Signatures (Encryption e))
|
||||
=> PubKey 'Sign (Encryption e)
|
||||
-> PrivKey 'Sign (Encryption e)
|
||||
makeBundleRefValue :: forall s . (ForSignedBox s, Signatures s)
|
||||
=> PubKey 'Sign s
|
||||
-> PrivKey 'Sign s
|
||||
-> BundleRef
|
||||
-> BundleRefValue e
|
||||
-> BundleRefValue s
|
||||
|
||||
makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @e pk sk ref
|
||||
makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @s pk sk ref
|
||||
|
||||
-- у нас может быть много способов хранить данные:
|
||||
-- сжимать целиком (эффективно, но медленно)
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ findFilesBy fp = liftIO do
|
|||
|
||||
findKeyRing :: forall s m . ( MonadUnliftIO m
|
||||
, SerialisedCredentials s
|
||||
, ForHBS2Basic s
|
||||
, For'HBS2Basic s
|
||||
)
|
||||
=> [FilePattern]
|
||||
-> PubKey 'Sign s
|
||||
|
|
@ -68,7 +68,7 @@ findKeyRing fp kr = do
|
|||
findKeyRingEntries :: forall s m . ( MonadUnliftIO m
|
||||
, SerialisedCredentials s
|
||||
, Hashable (PubKey 'Encrypt s)
|
||||
-- , ForHBS2Basic s
|
||||
-- , For'HBS2Basic s
|
||||
)
|
||||
=> [FilePattern]
|
||||
-> [PubKey 'Encrypt s]
|
||||
|
|
|
|||
|
|
@ -11,62 +11,62 @@ import Data.Hashable
|
|||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Function
|
||||
import Control.Monad.Identity
|
||||
|
||||
data SignedBox p e =
|
||||
SignedBox (PubKey 'Sign (Encryption e)) ByteString (Signature (Encryption e))
|
||||
data SignedBox p s =
|
||||
SignedBox (PubKey 'Sign s) ByteString (Signature s)
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving stock instance
|
||||
( Eq (PubKey 'Sign (Encryption e))
|
||||
, Eq (Signature (Encryption e))
|
||||
) => Eq (SignedBox p e)
|
||||
( Eq (PubKey 'Sign s)
|
||||
, Eq (Signature s)
|
||||
) => Eq (SignedBox p s)
|
||||
|
||||
instance ( Eq (PubKey 'Sign (Encryption e))
|
||||
, Eq (Signature (Encryption e))
|
||||
, Serialise (SignedBox p e)
|
||||
) => Hashable (SignedBox p e) where
|
||||
instance ( Eq (PubKey 'Sign s)
|
||||
, Eq (Signature s)
|
||||
, Serialise (SignedBox p s)
|
||||
) => Hashable (SignedBox p s) where
|
||||
hashWithSalt salt box = hashWithSalt salt (serialise box)
|
||||
|
||||
|
||||
type ForSignedBox e = ( Serialise ( PubKey 'Sign (Encryption e))
|
||||
, FromStringMaybe (PubKey 'Sign (Encryption e))
|
||||
, Serialise (Signature (Encryption e))
|
||||
, Signatures (Encryption e)
|
||||
, Hashable (PubKey 'Sign (Encryption e))
|
||||
type ForSignedBox s = ( Serialise ( PubKey 'Sign s)
|
||||
, FromStringMaybe (PubKey 'Sign s)
|
||||
, Serialise (Signature s)
|
||||
, Signatures s
|
||||
, Hashable (PubKey 'Sign s)
|
||||
)
|
||||
|
||||
instance ForSignedBox e => Serialise (SignedBox p e)
|
||||
instance ForSignedBox s => Serialise (SignedBox p s)
|
||||
|
||||
makeSignedBox :: forall e p . (Serialise p, ForSignedBox e, Signatures (Encryption e))
|
||||
=> PubKey 'Sign (Encryption e)
|
||||
-> PrivKey 'Sign (Encryption e)
|
||||
makeSignedBox :: forall s p . (Serialise p, ForSignedBox s, Signatures s)
|
||||
=> PubKey 'Sign s
|
||||
-> PrivKey 'Sign s
|
||||
-> p
|
||||
-> SignedBox p e
|
||||
-> SignedBox p s
|
||||
|
||||
makeSignedBox pk sk msg = SignedBox @p @e pk bs sign
|
||||
makeSignedBox pk sk msg = SignedBox @p @s pk bs sign
|
||||
where
|
||||
bs = LBS.toStrict (serialise msg)
|
||||
sign = makeSign @(Encryption e) sk bs
|
||||
sign = makeSign @s sk bs
|
||||
|
||||
|
||||
unboxSignedBox0 :: forall p e . (Serialise p, ForSignedBox e, Signatures (Encryption e))
|
||||
=> SignedBox p e
|
||||
-> Maybe (PubKey 'Sign (Encryption e), p)
|
||||
unboxSignedBox0 :: forall p s . (Serialise p, ForSignedBox s, Signatures s)
|
||||
=> SignedBox p s
|
||||
-> Maybe (PubKey 'Sign s, p)
|
||||
|
||||
unboxSignedBox0 (SignedBox pk bs sign) = runIdentity $ runMaybeT do
|
||||
guard $ verifySign @(Encryption e) pk sign bs
|
||||
guard $ verifySign @s pk sign bs
|
||||
p <- MaybeT $ pure $ deserialiseOrFail @p (LBS.fromStrict bs) & either (const Nothing) Just
|
||||
pure (pk, p)
|
||||
|
||||
unboxSignedBox :: forall p e . (Serialise p, ForSignedBox e, Signatures (Encryption e))
|
||||
unboxSignedBox :: forall p s . (Serialise p, ForSignedBox s, Signatures s)
|
||||
=> LBS.ByteString
|
||||
-> Maybe (PubKey 'Sign (Encryption e), p)
|
||||
-> Maybe (PubKey 'Sign s, p)
|
||||
|
||||
unboxSignedBox bs = runIdentity $ runMaybeT do
|
||||
|
||||
box <- MaybeT $ pure $ deserialiseOrFail @(SignedBox p e) bs
|
||||
box <- MaybeT $ pure $ deserialiseOrFail @(SignedBox p s) bs
|
||||
& either (pure Nothing) Just
|
||||
|
||||
MaybeT $ pure $ unboxSignedBox0 box
|
||||
|
||||
|
|
|
|||
|
|
@ -29,13 +29,9 @@ import Data.List qualified as List
|
|||
import Lens.Micro.Platform
|
||||
import Data.Kind
|
||||
|
||||
type instance PubKey 'Sign HBS2Basic = Sign.PublicKey
|
||||
type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
|
||||
type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey
|
||||
type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
|
||||
|
||||
instance Signatures HBS2Basic where
|
||||
type Signature HBS2Basic = Sign.Signature
|
||||
instance Signatures 'HBS2Basic where
|
||||
type Signature 'HBS2Basic = Sign.Signature
|
||||
makeSign = Sign.signDetached
|
||||
verifySign = Sign.signVerifyDetached
|
||||
|
||||
|
|
@ -68,10 +64,10 @@ class AsymmPubKey e ~ PubKey 'Encrypt e => Asymm e where
|
|||
class HasCredentials s m where
|
||||
getCredentials :: m (PeerCredentials s)
|
||||
|
||||
data KeyringEntry e =
|
||||
data KeyringEntry s =
|
||||
KeyringEntry
|
||||
{ _krPk :: PubKey 'Encrypt e
|
||||
, _krSk :: PrivKey 'Encrypt e
|
||||
{ _krPk :: PubKey 'Encrypt s
|
||||
, _krSk :: PrivKey 'Encrypt s
|
||||
, _krDesc :: Maybe Text
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
|
@ -94,24 +90,25 @@ data PeerCredentials s =
|
|||
makeLenses 'KeyringEntry
|
||||
makeLenses 'PeerCredentials
|
||||
|
||||
type ForHBS2Basic s = ( Signatures s
|
||||
, PrivKey 'Sign s ~ Sign.SecretKey
|
||||
, PubKey 'Sign s ~ Sign.PublicKey
|
||||
, Eq (PubKey 'Encrypt HBS2Basic)
|
||||
, IsEncoding (PubKey 'Encrypt s)
|
||||
, Eq (PubKey 'Encrypt HBS2Basic)
|
||||
, s ~ HBS2Basic
|
||||
)
|
||||
type For'HBS2Basic s = ( Signatures s
|
||||
, PrivKey 'Sign s ~ Sign.SecretKey
|
||||
, PubKey 'Sign s ~ Sign.PublicKey
|
||||
, Eq (PubKey 'Encrypt 'HBS2Basic)
|
||||
, IsEncoding (PubKey 'Encrypt s)
|
||||
, Eq (PubKey 'Encrypt 'HBS2Basic)
|
||||
, s ~ 'HBS2Basic
|
||||
)
|
||||
|
||||
type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e)
|
||||
, Serialise (PubKey 'Sign e)
|
||||
, Serialise (PubKey 'Encrypt e)
|
||||
, Serialise (PrivKey 'Encrypt e)
|
||||
)
|
||||
type SerialisedCredentials ( s :: CryptoScheme ) =
|
||||
( Serialise (PrivKey 'Sign s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (PubKey 'Encrypt s)
|
||||
, Serialise (PrivKey 'Encrypt s)
|
||||
)
|
||||
|
||||
instance SerialisedCredentials e => Serialise (KeyringEntry e)
|
||||
instance SerialisedCredentials s => Serialise (KeyringEntry s)
|
||||
|
||||
instance SerialisedCredentials e => Serialise (PeerCredentials e)
|
||||
instance SerialisedCredentials s => Serialise (PeerCredentials s)
|
||||
|
||||
newtype AsCredFile a = AsCredFile a
|
||||
|
||||
|
|
@ -150,7 +147,7 @@ addKeyPair txt cred = do
|
|||
pure $ cred & over peerKeyring (List.nub . (<> [kp]))
|
||||
|
||||
delKeyPair :: forall e m . ( MonadIO m
|
||||
, ForHBS2Basic e
|
||||
, For'HBS2Basic e
|
||||
)
|
||||
=> AsBase58 String -> PeerCredentials e -> m (PeerCredentials e)
|
||||
delKeyPair (AsBase58 pks) cred = do
|
||||
|
|
@ -160,7 +157,7 @@ delKeyPair (AsBase58 pks) cred = do
|
|||
pure $ cred & set peerKeyring rest
|
||||
|
||||
|
||||
parseCredentials :: forall s . ( -- ForHBS2Basic s
|
||||
parseCredentials :: forall s . ( -- For'HBS2Basic s
|
||||
SerialisedCredentials s
|
||||
)
|
||||
=> AsCredFile ByteString -> Maybe (PeerCredentials s)
|
||||
|
|
@ -234,11 +231,11 @@ instance IsEncoding (PubKey 'Encrypt e)
|
|||
pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke)))
|
||||
|
||||
|
||||
instance Asymm HBS2Basic where
|
||||
type AsymmKeypair HBS2Basic = Encrypt.Keypair
|
||||
type AsymmPrivKey HBS2Basic = Encrypt.SecretKey
|
||||
type AsymmPubKey HBS2Basic = Encrypt.PublicKey
|
||||
type CommonSecret HBS2Basic = Encrypt.CombinedKey
|
||||
instance Asymm 'HBS2Basic where
|
||||
type AsymmKeypair 'HBS2Basic = Encrypt.Keypair
|
||||
type AsymmPrivKey 'HBS2Basic = Encrypt.SecretKey
|
||||
type AsymmPubKey 'HBS2Basic = Encrypt.PublicKey
|
||||
type CommonSecret 'HBS2Basic = Encrypt.CombinedKey
|
||||
asymmNewKeypair = liftIO Encrypt.newKeypair
|
||||
privKeyFromKeypair = Encrypt.secretKey
|
||||
pubKeyFromKeypair = Encrypt.publicKey
|
||||
|
|
|
|||
|
|
@ -26,9 +26,9 @@ import Lens.Micro.Platform
|
|||
-- Contains an encryption public key, optional additional information,
|
||||
-- and a possible reference to an additional information block.
|
||||
|
||||
data SigilData e =
|
||||
data SigilData s =
|
||||
SigilData
|
||||
{ sigilDataEncKey :: PubKey 'Encrypt (Encryption e)
|
||||
{ sigilDataEncKey :: PubKey 'Encrypt s
|
||||
, sigilDataInfo :: Maybe Text
|
||||
, sigilDataExt :: Maybe HashRef
|
||||
}
|
||||
|
|
@ -40,34 +40,34 @@ data SigilData e =
|
|||
-- Includes a signature public key and signed 'SigilData',
|
||||
-- ensuring user authentication and verification.
|
||||
|
||||
data Sigil e =
|
||||
data Sigil s =
|
||||
Sigil
|
||||
{ sigilSignPk :: PubKey 'Sign (Encryption e)
|
||||
, sigilData :: SignedBox (SigilData e) e
|
||||
{ sigilSignPk :: PubKey 'Sign s
|
||||
, sigilData :: SignedBox (SigilData s) s
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
type ForSigil e = ( Serialise (PubKey 'Encrypt (Encryption e))
|
||||
, Serialise (PubKey 'Sign (Encryption e))
|
||||
, Serialise (Signature (Encryption e))
|
||||
, Signatures (Encryption e)
|
||||
, Hashable (PubKey 'Sign (Encryption e))
|
||||
, IsEncoding (PubKey 'Encrypt (Encryption e))
|
||||
, Eq (PubKey 'Encrypt (Encryption e))
|
||||
, FromStringMaybe (PubKey 'Sign (Encryption e))
|
||||
type ForSigil s = ( Serialise (PubKey 'Encrypt s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (Signature s)
|
||||
, Signatures s
|
||||
, Hashable (PubKey 'Sign s)
|
||||
, IsEncoding (PubKey 'Encrypt s)
|
||||
, Eq (PubKey 'Encrypt s)
|
||||
, FromStringMaybe (PubKey 'Sign s)
|
||||
)
|
||||
|
||||
type ForPrettySigil e =
|
||||
( IsEncoding (PubKey 'Encrypt (Encryption e))
|
||||
, Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
|
||||
type ForPrettySigil s =
|
||||
( IsEncoding (PubKey 'Encrypt s)
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
)
|
||||
|
||||
instance ForSigil e => Serialise (SigilData e)
|
||||
instance ForSigil e => Serialise (Sigil e)
|
||||
instance ForSigil s => Serialise (SigilData s)
|
||||
instance ForSigil s => Serialise (Sigil s)
|
||||
|
||||
|
||||
instance ForPrettySigil e => Pretty (SigilData e) where
|
||||
instance ForPrettySigil s => Pretty (SigilData s) where
|
||||
pretty s = vcat $ [ parens ("encrypt-pubkey" <+> dquotes epk)
|
||||
] <> catMaybes [pinfo, pext]
|
||||
where
|
||||
|
|
@ -75,7 +75,7 @@ instance ForPrettySigil e => Pretty (SigilData e) where
|
|||
pinfo = sigilDataInfo s >>= \x -> pure $ parens ("info" <+> dquotes (pretty x))
|
||||
pext = sigilDataExt s >>= \x -> pure $ parens ("ext" <+> dquotes (pretty x))
|
||||
|
||||
instance ForPrettySigil e => Pretty (Sigil e) where
|
||||
instance ForPrettySigil s => Pretty (Sigil s) where
|
||||
pretty s = vcat
|
||||
[ parens ("sign-pubkey" <+> psk)
|
||||
]
|
||||
|
|
@ -83,12 +83,12 @@ instance ForPrettySigil e => Pretty (Sigil e) where
|
|||
psk = dquotes (pretty (AsBase58 (sigilSignPk s)))
|
||||
|
||||
-- Nothing, если ключ отсутствует в Credentials
|
||||
makeSigilFromCredentials :: forall e . ForSigil e
|
||||
=> PeerCredentials (Encryption e)
|
||||
-> PubKey 'Encrypt (Encryption e)
|
||||
makeSigilFromCredentials :: forall s . ForSigil s
|
||||
=> PeerCredentials s
|
||||
-> PubKey 'Encrypt s
|
||||
-> Maybe Text
|
||||
-> Maybe HashRef
|
||||
-> Maybe (Sigil e)
|
||||
-> Maybe (Sigil s)
|
||||
|
||||
makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
|
||||
|
||||
|
|
@ -102,7 +102,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
|
|||
|
||||
let sd = SigilData ke i ha
|
||||
|
||||
let box = makeSignedBox @e ppk psk sd
|
||||
let box = makeSignedBox @s ppk psk sd
|
||||
|
||||
let sigil = Sigil
|
||||
{ sigilSignPk = view peerSignPk cred
|
||||
|
|
@ -112,7 +112,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
|
|||
pure sigil
|
||||
|
||||
|
||||
instance ForSigil e => Pretty (AsBase58 (Sigil e)) where
|
||||
instance ForSigil s => Pretty (AsBase58 (Sigil s)) where
|
||||
pretty (AsBase58 s) = "# sigil file. public data" <> line <> sd
|
||||
where
|
||||
sd = vcat $ fmap pretty
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ import HBS2.Base58
|
|||
import HBS2.Data.Types
|
||||
import HBS2.Data.Types.EncryptedBox
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
import Codec.Serialise
|
||||
|
|
@ -21,20 +20,18 @@ import Data.ByteString.Char8 (ByteString)
|
|||
import Data.List.Split (chunksOf)
|
||||
|
||||
|
||||
type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s)
|
||||
, Serialise (PubKey 'Encrypt s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (PrivKey 'Sign s)
|
||||
, Serialise (PrivKey 'Encrypt s)
|
||||
)
|
||||
type ForAccessKey (s :: CryptoScheme) = ( Crypto.IsEncoding (PubKey 'Encrypt s)
|
||||
, Serialise (PubKey 'Encrypt s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (PrivKey 'Sign s)
|
||||
, Serialise (PrivKey 'Encrypt s)
|
||||
)
|
||||
|
||||
|
||||
|
||||
---
|
||||
data family AccessKey ( s :: CryptoScheme )
|
||||
|
||||
data family AccessKey s
|
||||
|
||||
newtype instance AccessKey s =
|
||||
newtype instance AccessKey (s :: CryptoScheme) =
|
||||
AccessKeyNaClAsymm
|
||||
{ permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@ import HBS2.Base58
|
|||
import HBS2.Data.Types.EncryptedBox
|
||||
import HBS2.Data.Types.SmallEncryptedBlock
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Auth.Schema
|
||||
import HBS2.Hash
|
||||
import HBS2.Merkle
|
||||
import HBS2.Data.Detect
|
||||
|
|
@ -96,14 +97,17 @@ data instance ToEncrypt 'Symm s LBS.ByteString =
|
|||
}
|
||||
deriving (Generic)
|
||||
|
||||
type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
|
||||
, PubKey 'Encrypt s ~ AK.PublicKey
|
||||
, PrivKey 'Encrypt s ~ AK.SecretKey
|
||||
, Serialise (PubKey 'Encrypt s)
|
||||
, Serialise GroupSecret
|
||||
, Serialise SK.Nonce
|
||||
, FromStringMaybe (PubKey 'Encrypt s)
|
||||
)
|
||||
type ForGroupKeySymm (s :: CryptoScheme ) =
|
||||
(
|
||||
-- Eq (PubKey 'Encrypt s)
|
||||
-- , PubKey 'Encrypt s
|
||||
-- , PrivKey 'Encrypt s
|
||||
Serialise (PubKey 'Encrypt s)
|
||||
, Serialise GroupSecret
|
||||
, Serialise SK.Nonce
|
||||
, FromStringMaybe (PubKey 'Encrypt s)
|
||||
, Hashable (PubKey 'Encrypt s)
|
||||
)
|
||||
|
||||
instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s)
|
||||
|
||||
|
|
@ -142,7 +146,7 @@ instance ( Serialise (GroupKey 'Symm s)
|
|||
pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
|
||||
|
||||
|
||||
generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m)
|
||||
generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
|
||||
=> Maybe GroupSecret
|
||||
-> [PubKey 'Encrypt s]
|
||||
-> m (GroupKey 'Symm s)
|
||||
|
|
@ -155,7 +159,10 @@ generateGroupKey mbk pks = GroupKeySymm <$> create
|
|||
box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
|
||||
pure (pk, box)
|
||||
|
||||
lookupGroupKey :: ForGroupKeySymm s
|
||||
lookupGroupKey :: forall s . ( ForGroupKeySymm s
|
||||
, PubKey 'Encrypt s ~ AK.PublicKey
|
||||
, PrivKey 'Encrypt s ~ AK.SecretKey
|
||||
)
|
||||
=> PrivKey 'Encrypt s
|
||||
-> PubKey 'Encrypt s
|
||||
-> GroupKey 'Symm s
|
||||
|
|
@ -278,8 +285,8 @@ instance ( MonadIO m
|
|||
, MonadError OperationError m
|
||||
, h ~ HbSync
|
||||
, Storage s h ByteString m
|
||||
, sch ~ 'HBS2Basic
|
||||
-- TODO: why?
|
||||
, sch ~ HBS2Basic
|
||||
) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
|
||||
|
||||
data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
|
||||
|
|
@ -389,6 +396,8 @@ decryptBlock :: forall t s sto h m . ( MonadIO m
|
|||
, MonadError OperationError m
|
||||
, Storage sto h ByteString m
|
||||
, ForGroupKeySymm s
|
||||
, PubKey 'Encrypt s ~ AK.PublicKey
|
||||
, PrivKey 'Encrypt s ~ AK.SecretKey
|
||||
, h ~ HbSync
|
||||
, Serialise t
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ module HBS2.Net.Auth.Schema
|
|||
, module HBS2.Net.Proto.Types
|
||||
) where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Hash
|
||||
|
|
@ -17,21 +17,36 @@ import Crypto.PubKey.Ed25519 qualified as Ed
|
|||
import Crypto.KDF.HKDF qualified as HKDF
|
||||
import Crypto.Saltine.Class qualified as Saltine
|
||||
import Crypto.Saltine.Class (IsEncoding(..))
|
||||
import Crypto.Saltine.Core.Sign qualified as Sign
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
|
||||
import Codec.Serialise
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteArray ( convert)
|
||||
|
||||
data HBS2Basic
|
||||
|
||||
type instance Encryption L4Proto = HBS2Basic
|
||||
-- type ForSignatures s = ( Serialise ( PubKey 'Sign s)
|
||||
-- , FromStringMaybe (PubKey 'Sign s)
|
||||
-- , Signatures s
|
||||
-- )
|
||||
|
||||
type instance Encryption UNIX = HBS2Basic
|
||||
type instance Encryption L4Proto = 'HBS2Basic
|
||||
|
||||
type instance Encryption UNIX = 'HBS2Basic
|
||||
|
||||
type ForDerivedKey s = (IsEncoding (PrivKey 'Sign s), IsEncoding (PubKey 'Sign s))
|
||||
|
||||
instance (MonadIO m, ForDerivedKey s, s ~ HBS2Basic) => HasDerivedKey s 'Sign Word64 m where
|
||||
type instance PubKey 'Sign 'HBS2Basic = Sign.PublicKey
|
||||
type instance PrivKey 'Sign 'HBS2Basic = Sign.SecretKey
|
||||
type instance PubKey 'Encrypt 'HBS2Basic = Encrypt.PublicKey
|
||||
type instance PrivKey 'Encrypt 'HBS2Basic = Encrypt.SecretKey
|
||||
|
||||
-- type PrivKey 'Encrypt s
|
||||
|
||||
-- type instance PubKey 'Sign
|
||||
|
||||
instance (MonadIO m, ForDerivedKey s, s ~ 'HBS2Basic) => HasDerivedKey s 'Sign Word64 m where
|
||||
derivedKey nonce sk = do
|
||||
|
||||
sk0 <- liftIO $ throwCryptoErrorIO (Ed.secretKey k0)
|
||||
|
|
|
|||
|
|
@ -76,10 +76,10 @@ mySipHash s = BA.sipHash (SipKey a b) s
|
|||
--
|
||||
|
||||
|
||||
data ByPassOpts e =
|
||||
data ByPassOpts s =
|
||||
ByPassOpts
|
||||
{ byPassEnabled :: Bool
|
||||
, byPassKeyAllowed :: PubKey 'Sign (Encryption e) -> IO Bool
|
||||
, byPassKeyAllowed :: PubKey 'Sign s -> IO Bool
|
||||
, byPassTimeRange :: Maybe (Int, Int)
|
||||
}
|
||||
|
||||
|
|
@ -101,7 +101,7 @@ instance Serialise ByPassStat
|
|||
|
||||
data ByPass e them =
|
||||
ByPass
|
||||
{ opts :: ByPassOpts e
|
||||
{ opts :: ByPassOpts (Encryption e)
|
||||
, self :: Peer e
|
||||
, pks :: PubKey 'Sign (Encryption e)
|
||||
, sks :: PrivKey 'Sign (Encryption e)
|
||||
|
|
@ -128,7 +128,7 @@ type ForByPass e = ( Hashable (Peer e)
|
|||
, Serialise (PubKey 'Sign (Encryption e))
|
||||
, PrivKey 'Encrypt (Encryption e) ~ PKE.SecretKey
|
||||
, PubKey 'Encrypt (Encryption e) ~ PKE.PublicKey
|
||||
, ForSignedBox e
|
||||
, ForSignedBox (Encryption e)
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -136,12 +136,12 @@ data HEYBox e =
|
|||
HEYBox Int (PubKey 'Encrypt (Encryption e))
|
||||
deriving stock Generic
|
||||
|
||||
instance ForByPass e => Serialise (HEYBox e)
|
||||
instance ForByPass s => Serialise (HEYBox s)
|
||||
|
||||
data EncryptHandshake e =
|
||||
HEY
|
||||
{ heyNonceA :: NonceA
|
||||
, heyBox :: SignedBox (HEYBox e) e
|
||||
, heyBox :: SignedBox (HEYBox e) (Encryption e)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
|
@ -210,7 +210,7 @@ newByPassMessaging :: forall e w m . ( ForByPass e
|
|||
, MonadIO m
|
||||
, Messaging w e ByteString
|
||||
)
|
||||
=> ByPassOpts e
|
||||
=> ByPassOpts (Encryption e)
|
||||
-> w
|
||||
-> Peer e
|
||||
-> PubKey 'Sign (Encryption e)
|
||||
|
|
@ -370,10 +370,11 @@ makeKey a b = runIdentity do
|
|||
pure $ (f0 `shiftL` 16) .|. f1
|
||||
|
||||
|
||||
sendHey :: forall e w m . ( ForByPass e
|
||||
, Messaging w e ByteString
|
||||
, MonadIO m
|
||||
)
|
||||
sendHey :: forall e w m s . ( ForByPass e
|
||||
, Messaging w e ByteString
|
||||
, MonadIO m
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> ByPass e w
|
||||
-> Peer e
|
||||
-> m ()
|
||||
|
|
@ -387,7 +388,7 @@ sendHey bus whom = do
|
|||
ts <- liftIO getPOSIXTime <&> round
|
||||
|
||||
let hbox = HEYBox @e ts (pke bus)
|
||||
let box = makeSignedBox @e (pks bus) (sks bus) hbox
|
||||
let box = makeSignedBox @s (pks bus) (sks bus) hbox
|
||||
let hey = HEY @e (nonceA bus) box
|
||||
let msg = pref <> serialise hey
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@ module HBS2.Net.Proto.Types
|
|||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Clock
|
||||
import HBS2.Net.IP.Addr
|
||||
|
||||
import Control.Applicative
|
||||
|
|
@ -37,14 +36,19 @@ data CryptoAction = Sign | Encrypt
|
|||
data GroupKeyScheme = Symm | Asymm
|
||||
deriving stock (Eq,Ord,Show,Data,Generic)
|
||||
|
||||
type family PubKey (a :: CryptoAction) e :: Type
|
||||
type family PrivKey (a :: CryptoAction) e :: Type
|
||||
data CryptoScheme = HBS2Basic
|
||||
|
||||
type family Encryption e :: Type
|
||||
type family PubKey (a :: CryptoAction) (s :: CryptoScheme) :: Type
|
||||
|
||||
type family PrivKey (a :: CryptoAction) (s :: CryptoScheme) :: Type
|
||||
|
||||
type family Encryption e :: CryptoScheme
|
||||
|
||||
type instance Encryption L4Proto = 'HBS2Basic
|
||||
|
||||
type family KeyActionOf k :: CryptoAction
|
||||
|
||||
data family GroupKey (scheme :: GroupKeyScheme) s
|
||||
data family GroupKey (scheme :: GroupKeyScheme) (s :: CryptoScheme)
|
||||
|
||||
-- NOTE: throws-error
|
||||
class MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where
|
||||
|
|
@ -53,9 +57,9 @@ class MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where
|
|||
-- TODO: move-to-an-appropriate-place
|
||||
newtype AsGroupKeyFile a = AsGroupKeyFile a
|
||||
|
||||
data family ToEncrypt (scheme :: GroupKeyScheme) s a -- = ToEncrypt a
|
||||
data family ToEncrypt (scheme :: GroupKeyScheme) (s :: CryptoScheme) a -- = ToEncrypt a
|
||||
|
||||
data family ToDecrypt (scheme :: GroupKeyScheme) s a
|
||||
data family ToDecrypt (scheme :: GroupKeyScheme) (s :: CryptoScheme) a
|
||||
|
||||
-- FIXME: move-to-a-crypto-definition-modules
|
||||
|
||||
|
|
@ -168,7 +172,6 @@ instance HasPeer L4Proto where
|
|||
}
|
||||
deriving stock (Eq,Ord,Show,Generic)
|
||||
|
||||
|
||||
instance AddrPriority (Peer L4Proto) where
|
||||
addrPriority (PeerL4 _ sa) = addrPriority sa
|
||||
|
||||
|
|
|
|||
|
|
@ -15,13 +15,13 @@ import Data.Word
|
|||
testDerivedKeys1 :: IO ()
|
||||
testDerivedKeys1 = do
|
||||
|
||||
cred <- newCredentials @HBS2Basic
|
||||
cred <- newCredentials @'HBS2Basic
|
||||
|
||||
let _ = view peerSignPk cred
|
||||
let sk = view peerSignSk cred
|
||||
|
||||
let nonce = 0x123456780928934 :: Word64
|
||||
(pk1,sk1) <- derivedKey @HBS2Basic @'Sign nonce sk
|
||||
(pk1,sk1) <- derivedKey @'HBS2Basic @'Sign nonce sk
|
||||
|
||||
let box = makeSignedBox @L4Proto pk1 sk1 (42 :: Word32)
|
||||
|
||||
|
|
|
|||
|
|
@ -64,8 +64,8 @@ import System.Exit
|
|||
type Config = [Syntax C]
|
||||
|
||||
|
||||
type RLWW = LWWRefKey HBS2Basic
|
||||
type RRefLog = RefLogKey HBS2Basic
|
||||
type RLWW = LWWRefKey 'HBS2Basic
|
||||
type RRefLog = RefLogKey 'HBS2Basic
|
||||
|
||||
newtype Watcher =
|
||||
Watcher [Syntax C]
|
||||
|
|
@ -81,7 +81,7 @@ instance Pretty Ref where
|
|||
pretty (RefLWW r) = parens $ "lwwref" <+> dquotes (pretty r)
|
||||
|
||||
newtype AnyPolledRef =
|
||||
AnyPolledRef (PubKey 'Sign HBS2Basic)
|
||||
AnyPolledRef (PubKey 'Sign 'HBS2Basic)
|
||||
deriving (Eq,Generic)
|
||||
|
||||
instance Hashable AnyPolledRef
|
||||
|
|
@ -91,7 +91,7 @@ deriving newtype instance Hashable Id
|
|||
|
||||
instance Pretty AnyPolledRef where
|
||||
pretty (AnyPolledRef r) = pretty (AsBase58 r)
|
||||
-- deriving newtype instance Pretty (PubKey 'Sign HBS2Basic) => Pretty AnyPolledRef
|
||||
-- deriving newtype instance Pretty (PubKey 'Sign 'HBS2Basic) => Pretty AnyPolledRef
|
||||
|
||||
instance FromStringMaybe AnyPolledRef where
|
||||
fromStringMay = fmap AnyPolledRef . fromStringMay
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ main = do
|
|||
|
||||
|
||||
where
|
||||
pLww :: ReadM (LWWRefKey HBS2Basic)
|
||||
pLww :: ReadM (LWWRefKey 'HBS2Basic)
|
||||
pLww = maybeReader fromStringMay
|
||||
|
||||
|
||||
|
|
@ -66,7 +66,7 @@ instance Monad m => HasAPI LWWRefAPI UNIX (MyApp m) where
|
|||
instance Monad m => HasAPI RefLogAPI UNIX (MyApp m) where
|
||||
getAPI = asks _refLogAPI
|
||||
|
||||
subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey HBS2Basic -> m ()
|
||||
subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey 'HBS2Basic -> m ()
|
||||
subscribe soname' ref = do
|
||||
|
||||
soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc"
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ pRefLogId :: ReadM RefLogId
|
|||
pRefLogId = maybeReader (fromStringMay @RefLogId)
|
||||
|
||||
|
||||
pLwwKey :: ReadM (LWWRefKey HBS2Basic)
|
||||
pLwwKey :: ReadM (LWWRefKey 'HBS2Basic)
|
||||
pLwwKey = maybeReader fromStringMay
|
||||
|
||||
pHashRef :: ReadM HashRef
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ sendLine = liftIO . IO.putStrLn
|
|||
die :: (MonadIO m, Pretty a) => a -> m b
|
||||
die s = liftIO $ Exit.die (show $ pretty s)
|
||||
|
||||
parseURL :: String -> Maybe (LWWRefKey HBS2Basic)
|
||||
parseURL :: String -> Maybe (LWWRefKey 'HBS2Basic)
|
||||
parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
|
||||
where
|
||||
p = do
|
||||
|
|
@ -56,7 +56,7 @@ parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
|
|||
|
||||
Atto.takeWhile1 (`elem` getAlphabet)
|
||||
<&> BS8.unpack
|
||||
<&> fromStringMay @(LWWRefKey HBS2Basic)
|
||||
<&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
>>= maybe (fail "invalid reflog key") pure
|
||||
|
||||
parsePush :: String -> Maybe (Maybe GitRef, GitRef)
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ data GitEnv =
|
|||
, _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX
|
||||
, _db :: DBPipeEnv
|
||||
, _progress :: AnyProgress
|
||||
, _keyringCache :: TVar (HashMap HashRef [KeyringEntry HBS2Basic])
|
||||
, _keyringCache :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic])
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -153,7 +153,7 @@ export :: ( GitPerks m
|
|||
, GroupKeyOperations m
|
||||
, HasAPI PeerAPI UNIX m
|
||||
)
|
||||
=> LWWRefKey HBS2Basic
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> [(GitRef,Maybe GitHash)]
|
||||
-> m ()
|
||||
export key refs = do
|
||||
|
|
@ -177,7 +177,7 @@ export key refs = do
|
|||
>>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0))
|
||||
pure ( view peerSignSk creds, view peerSignPk creds )
|
||||
|
||||
(puk,sk) <- derivedKey @HBS2Basic @'Sign lwwRefSeed sk0
|
||||
(puk,sk) <- derivedKey @'HBS2Basic @'Sign lwwRefSeed sk0
|
||||
|
||||
subscribeRefLog puk
|
||||
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ merelySubscribeRepo :: forall e s m . ( GitPerks m
|
|||
, e ~ L4Proto
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> LWWRefKey HBS2Basic
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> m (Maybe (PubKey 'Sign s))
|
||||
merelySubscribeRepo lwwKey = do
|
||||
|
||||
|
|
@ -108,7 +108,7 @@ importRepoWait :: ( GitPerks m
|
|||
, HasAPI LWWRefAPI UNIX m
|
||||
, HasAPI RefLogAPI UNIX m
|
||||
)
|
||||
=> LWWRefKey HBS2Basic
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> m ()
|
||||
|
||||
importRepoWait lwwKey = do
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ class HasProgress a where
|
|||
|
||||
data ProgressEvent =
|
||||
ImportIdle
|
||||
| ImportWaitLWW Int (LWWRefKey HBS2Basic)
|
||||
| ImportWaitLWW Int (LWWRefKey 'HBS2Basic)
|
||||
| ImportRefLogStart RefLogId
|
||||
| ImportRefLogDone RefLogId (Maybe HashRef)
|
||||
| ImportWaitTx HashRef
|
||||
|
|
|
|||
|
|
@ -27,12 +27,12 @@ subscribeRefLog puk = do
|
|||
api <- getAPI @PeerAPI @UNIX
|
||||
void $ callService @RpcPollAdd api (puk, "reflog", 13)
|
||||
|
||||
subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
|
||||
subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
subscribeLWWRef puk = do
|
||||
api <- getAPI @PeerAPI @UNIX
|
||||
void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17)
|
||||
|
||||
fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
|
||||
fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
fetchLWWRef key = do
|
||||
api <- getAPI @LWWRefAPI @UNIX
|
||||
void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ instance Pretty (AsBase58 a) => ToField (Base58Field a) where
|
|||
instance IsString a => FromField (Base58Field a) where
|
||||
fromField = fmap (Base58Field . fromString) . fromField @String
|
||||
|
||||
instance FromField (RefLogKey HBS2Basic) where
|
||||
instance FromField (RefLogKey 'HBS2Basic) where
|
||||
fromField = fmap fromString . fromField @String
|
||||
|
||||
instance ToField HashRef where
|
||||
|
|
@ -51,7 +51,7 @@ instance FromField GitRef where
|
|||
instance FromField GitHash where
|
||||
fromField = fmap fromString . fromField @String
|
||||
|
||||
instance FromField (LWWRefKey HBS2Basic) where
|
||||
instance FromField (LWWRefKey 'HBS2Basic) where
|
||||
fromField = fmap fromString . fromField @String
|
||||
|
||||
createStateDir :: (GitPerks m, MonadReader GitEnv m) => m ()
|
||||
|
|
@ -367,16 +367,16 @@ limit 1
|
|||
|] (Only (Base58Field reflog)) <&> listToMaybe
|
||||
|
||||
|
||||
insertLww :: MonadIO m => LWWRefKey HBS2Basic -> Word64 -> RefLogId -> DBPipeM m ()
|
||||
insertLww :: MonadIO m => LWWRefKey 'HBS2Basic -> Word64 -> RefLogId -> DBPipeM m ()
|
||||
insertLww lww snum reflog = do
|
||||
insert [qc|
|
||||
INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?)
|
||||
ON CONFLICT (hash,seq,reflog) DO NOTHING
|
||||
|] (Base58Field lww, snum, Base58Field reflog)
|
||||
|
||||
selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey HBS2Basic, Word64, RefLogId)]
|
||||
selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey 'HBS2Basic, Word64, RefLogId)]
|
||||
selectAllLww = do
|
||||
select_ [qc|
|
||||
SELECT hash, seq, reflog FROM lww
|
||||
|] <&> fmap (over _3 (fromRefLogKey @HBS2Basic))
|
||||
|] <&> fmap (over _3 (fromRefLogKey @'HBS2Basic))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ import HBS2.Storage.Operations.ByteString
|
|||
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
|
||||
type GK0 = GroupKey 'Symm HBS2Basic
|
||||
type GK0 = GroupKey 'Symm 'HBS2Basic
|
||||
|
||||
readGK0 :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m GK0
|
||||
readGK0 sto h = do
|
||||
|
|
@ -22,5 +22,5 @@ loadGK0FromFile fp = runMaybeT do
|
|||
content <- liftIO (try @_ @IOError (LBS.readFile fp))
|
||||
>>= toMPlus
|
||||
|
||||
toMPlus $ parseGroupKey @HBS2Basic (AsGroupKeyFile content)
|
||||
toMPlus $ parseGroupKey @'HBS2Basic (AsGroupKeyFile content)
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
module HBS2.Git.Data.LWWBlock
|
||||
( module HBS2.Git.Data.LWWBlock
|
||||
, module HBS2.Peer.Proto.LWWRef
|
||||
, HBS2Basic
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
|
|
@ -42,19 +41,19 @@ import Control.Monad.Trans.Maybe
|
|||
-- (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX])
|
||||
--
|
||||
|
||||
data LWWBlockData e =
|
||||
data LWWBlockData s =
|
||||
LWWBlockData
|
||||
{ lwwRefSeed :: Word64
|
||||
, lwwRefLogPubKey :: PubKey 'Sign (Encryption e)
|
||||
, lwwRefLogPubKey :: PubKey 'Sign s
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
data LWWBlock e =
|
||||
LWWBlock1 { lwwBlockData :: LWWBlockData e }
|
||||
data LWWBlock s =
|
||||
LWWBlock1 { lwwBlockData :: LWWBlockData s }
|
||||
deriving stock Generic
|
||||
|
||||
instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e)
|
||||
instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e)
|
||||
instance Serialise (PubKey 'Sign s) => Serialise (LWWBlockData s)
|
||||
instance Serialise (PubKey 'Sign s) => Serialise (LWWBlock s)
|
||||
|
||||
|
||||
data LWWBlockOpError =
|
||||
|
|
@ -67,38 +66,34 @@ instance Exception LWWBlockOpError
|
|||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
readLWWBlock :: forall e s m . ( MonadIO m
|
||||
, Signatures s
|
||||
, s ~ Encryption e
|
||||
, ForLWWRefProto e
|
||||
, IsRefPubKey s
|
||||
, e ~ L4Proto
|
||||
)
|
||||
readLWWBlock :: forall s m . ( MonadIO m
|
||||
, Signatures s
|
||||
, ForLWWRefProto s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
=> AnyStorage
|
||||
-> LWWRefKey s
|
||||
-> m (Maybe (LWWRef e, LWWBlockData e))
|
||||
-> m (Maybe (LWWRef s, LWWBlockData s))
|
||||
|
||||
readLWWBlock sto k = runMaybeT do
|
||||
|
||||
w@LWWRef{..} <- runExceptT (readLWWRef @e sto k)
|
||||
w@LWWRef{..} <- runExceptT (readLWWRef @s sto k)
|
||||
>>= toMPlus
|
||||
>>= toMPlus
|
||||
|
||||
getBlock sto (fromHashRef lwwValue)
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @(LWWBlock e)
|
||||
<&> deserialiseOrFail @(LWWBlock s)
|
||||
>>= toMPlus
|
||||
<&> lwwBlockData
|
||||
<&> (w,)
|
||||
|
||||
initLWWRef :: forall e s m . ( MonadIO m
|
||||
initLWWRef :: forall s m . ( MonadIO m
|
||||
, MonadError LWWBlockOpError m
|
||||
, IsRefPubKey s
|
||||
, ForSignedBox e
|
||||
, ForSignedBox s
|
||||
, HasDerivedKey s 'Sign Word64 m
|
||||
, s ~ Encryption e
|
||||
, Signatures s
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> AnyStorage
|
||||
-> Maybe Word64
|
||||
|
|
@ -116,7 +111,7 @@ initLWWRef sto seed' findSk lwwKey = do
|
|||
lww0 <- runMaybeT do
|
||||
getRef sto lwwKey >>= toMPlus
|
||||
>>= getBlock sto >>= toMPlus
|
||||
<&> deserialiseOrFail @(SignedBox (LWWRef e) e)
|
||||
<&> deserialiseOrFail @(SignedBox (LWWRef s) s)
|
||||
>>= toMPlus
|
||||
<&> unboxSignedBox0
|
||||
>>= toMPlus
|
||||
|
|
@ -124,7 +119,7 @@ initLWWRef sto seed' findSk lwwKey = do
|
|||
|
||||
(pk1, _) <- derivedKey @s @'Sign seed sk0
|
||||
|
||||
let newLwwData = LWWBlock1 (LWWBlockData @e seed pk1)
|
||||
let newLwwData = LWWBlock1 @s (LWWBlockData seed pk1)
|
||||
|
||||
hx <- putBlock sto (serialise newLwwData)
|
||||
>>= orThrowError LWWBlockOpStorageError
|
||||
|
|
|
|||
|
|
@ -2,6 +2,6 @@ module HBS2.Git.Data.RefLog where
|
|||
|
||||
import HBS2.Git.Client.Prelude
|
||||
|
||||
type RefLogId = PubKey 'Sign HBS2Basic
|
||||
type RefLogId = PubKey 'Sign 'HBS2Basic
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ instance Exception TxKeyringNotFound
|
|||
|
||||
class GroupKeyOperations m where
|
||||
openGroupKey :: GK0 -> m (Maybe GroupSecret)
|
||||
loadKeyrings :: HashRef -> m [KeyringEntry HBS2Basic]
|
||||
loadKeyrings :: HashRef -> m [KeyringEntry 'HBS2Basic]
|
||||
|
||||
makeRepoHeadSimple :: MonadIO m
|
||||
=> Text
|
||||
|
|
@ -85,7 +85,7 @@ makeRepoHeadSimple name brief manifest gk refs = do
|
|||
writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef
|
||||
writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef
|
||||
|
||||
makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic)
|
||||
makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ 'HBS2Basic)
|
||||
=> AnyStorage
|
||||
-> Bool -- ^ rewrite bundle merkle tree with new gk0
|
||||
-> Rank -- ^ tx rank
|
||||
|
|
@ -98,7 +98,7 @@ makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic)
|
|||
|
||||
makeTx sto rewrite r puk findSk rh prev lbss = do
|
||||
|
||||
let rfk = RefLogKey @HBS2Basic puk
|
||||
let rfk = RefLogKey @'HBS2Basic puk
|
||||
|
||||
privk <- findSk puk
|
||||
>>= orThrow TxKeyringNotFound
|
||||
|
|
@ -140,7 +140,7 @@ makeTx sto rewrite r puk findSk rh prev lbss = do
|
|||
|
||||
debug $ "update GK0 for existed block" <+> pretty bh
|
||||
let rcpt = HM.keys (recipients (wbeGk0 writeEnv))
|
||||
gk1 <- generateGroupKey @HBS2Basic (Just gks) rcpt
|
||||
gk1 <- generateGroupKey @'HBS2Basic (Just gks) rcpt
|
||||
|
||||
gk1h <- writeAsMerkle sto (serialise gk1)
|
||||
|
||||
|
|
@ -166,7 +166,7 @@ makeTx sto rewrite r puk findSk rh prev lbss = do
|
|||
& serialise
|
||||
& LBS.toStrict
|
||||
|
||||
makeRefLogUpdate @L4Proto @HBS2Basic puk privk tx
|
||||
makeRefLogUpdate @L4Proto @'HBS2Basic puk privk tx
|
||||
|
||||
|
||||
unpackTx :: MonadIO m
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Git.Data.Tx.Index where
|
||||
|
||||
import HBS2.Git.Client.Prelude
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Types.SignedBox
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
|
||||
|
||||
-- |
|
||||
-- Module : HBS2.Git.Data.Tx.Index
|
||||
-- Description : hbs2-git index data structures
|
||||
--
|
||||
|
||||
-- FIXME: fix-all-this-constraint-absurde
|
||||
type ForGitIndex s = ( ForSignedBox s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
|
||||
data RepoForkInfo e =
|
||||
RepoForkInfoNone
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
data GitRepoAnnounceData s =
|
||||
GitRepoAnnounceData
|
||||
{ repoLwwRef :: LWWRefKey s
|
||||
, repoForkInfo :: Maybe (RepoForkInfo s)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
data GitRepoAnnounce s =
|
||||
GitRepoAnnounce
|
||||
{ gitRepoAnnounce :: SignedBox (GitRepoAnnounceData s) s
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
instance ForGitIndex s => Serialise (RepoForkInfo s)
|
||||
instance ForGitIndex s => Serialise (GitRepoAnnounceData s)
|
||||
instance ForGitIndex s => Serialise (GitRepoAnnounce s)
|
||||
|
||||
|
||||
data NotifyCredentials s =
|
||||
NotifyCredentials (PubKey 'Sign s) (PrivKey 'Sign s)
|
||||
|
||||
data RepoCredentials s =
|
||||
RepoCredentials
|
||||
{ rcPubKey :: PubKey 'Sign s
|
||||
, rcSeckey :: PrivKey 'Sign s
|
||||
}
|
||||
|
||||
makeNotificationTx :: forall s m . (Monad m, ForGitIndex s)
|
||||
=> NotifyCredentials s
|
||||
-> RepoCredentials s
|
||||
-> Maybe (RepoForkInfo s)
|
||||
-> m ByteString
|
||||
makeNotificationTx ncred repocred forkInfo = do
|
||||
-- makeSignedBox @e (LBS.toStrict $ serialise tx)
|
||||
let annData = GitRepoAnnounceData @s (LWWRefKey $ rcPubKey repocred)
|
||||
undefined
|
||||
|
||||
|
|
@ -101,6 +101,7 @@ library
|
|||
HBS2.Git.Local.CLI
|
||||
|
||||
HBS2.Git.Data.Tx.Git
|
||||
HBS2.Git.Data.Tx.Index
|
||||
HBS2.Git.Data.GK
|
||||
HBS2.Git.Data.RefLog
|
||||
HBS2.Git.Data.LWWBlock
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ 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)
|
||||
|
||||
-- Парсер для команд
|
||||
commands :: (AppPerks m) => Parser (Command m)
|
||||
|
|
@ -93,7 +93,7 @@ updateKeys = do
|
|||
|
||||
bs <- liftIO $ BS.readFile fn
|
||||
|
||||
krf <- parseCredentials @HBS2Basic (AsCredFile bs) & toMPlus
|
||||
krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
|
||||
|
||||
let skp = view peerSignPk krf
|
||||
|
||||
|
|
|
|||
|
|
@ -51,10 +51,10 @@ runKeymanClient action = do
|
|||
loadCredentials :: forall a m .
|
||||
( MonadIO m
|
||||
, SomePubKeyPerks a
|
||||
, SerialisedCredentials HBS2Basic
|
||||
, SerialisedCredentials 'HBS2Basic
|
||||
)
|
||||
=> a
|
||||
-> KeyManClient m (Maybe (PeerCredentials HBS2Basic))
|
||||
-> KeyManClient m (Maybe (PeerCredentials 'HBS2Basic))
|
||||
loadCredentials k = KeyManClient do
|
||||
|
||||
fnames <- select @(Only FilePath) [qc|
|
||||
|
|
@ -71,10 +71,10 @@ loadCredentials k = KeyManClient do
|
|||
|
||||
loadKeyRingEntry :: forall m .
|
||||
( MonadIO m
|
||||
, SerialisedCredentials HBS2Basic
|
||||
, SerialisedCredentials 'HBS2Basic
|
||||
)
|
||||
=> PubKey 'Encrypt HBS2Basic
|
||||
-> KeyManClient m (Maybe (KeyringEntry HBS2Basic))
|
||||
=> PubKey 'Encrypt 'HBS2Basic
|
||||
-> KeyManClient m (Maybe (KeyringEntry 'HBS2Basic))
|
||||
loadKeyRingEntry pk = KeyManClient do
|
||||
runMaybeT do
|
||||
fn <- toMPlus =<< lift (selectKeyFile pk)
|
||||
|
|
@ -87,10 +87,10 @@ loadKeyRingEntry pk = KeyManClient do
|
|||
|
||||
loadKeyRingEntries :: forall m .
|
||||
( MonadIO m
|
||||
, SerialisedCredentials HBS2Basic
|
||||
, SerialisedCredentials 'HBS2Basic
|
||||
)
|
||||
=> [PubKey 'Encrypt HBS2Basic]
|
||||
-> KeyManClient m [(Word, KeyringEntry HBS2Basic)]
|
||||
=> [PubKey 'Encrypt 'HBS2Basic]
|
||||
-> KeyManClient m [(Word, KeyringEntry 'HBS2Basic)]
|
||||
loadKeyRingEntries pks = KeyManClient do
|
||||
r <- for pks $ \pk -> runMaybeT do
|
||||
fn <- lift (selectKeyFile pk) >>= toMPlus
|
||||
|
|
|
|||
|
|
@ -730,12 +730,13 @@ blockDownloadLoop env0 = do
|
|||
updatePeerInfo False p pinfo
|
||||
|
||||
|
||||
processBlock :: forall e m . ( MonadIO m
|
||||
, HasStorage m
|
||||
, MyPeer e
|
||||
, ForSignedBox e
|
||||
, HasPeerLocator e (BlockDownloadM e m)
|
||||
)
|
||||
processBlock :: forall e s m . ( MonadIO m
|
||||
, HasStorage m
|
||||
, MyPeer e
|
||||
, ForSignedBox s
|
||||
, s ~ Encryption e
|
||||
, HasPeerLocator e (BlockDownloadM e m)
|
||||
)
|
||||
=> Hash HbSync
|
||||
-> BlockDownloadM e m ()
|
||||
|
||||
|
|
@ -820,7 +821,7 @@ processBlock h = do
|
|||
bs <- MaybeT $ pure block
|
||||
|
||||
-- TODO: check-if-we-somehow-trust-this-key
|
||||
(pk, BundleRefSimple ref) <- MaybeT $ pure $ deserialiseOrFail @(BundleRefValue e) bs
|
||||
(pk, BundleRefSimple ref) <- MaybeT $ pure $ deserialiseOrFail @(BundleRefValue s) bs
|
||||
& either (const Nothing) unboxBundleRef
|
||||
|
||||
debug $ "GOT BundleRefValue" <+> parens (pretty ref)
|
||||
|
|
|
|||
|
|
@ -61,5 +61,5 @@ pRpcCommon = do
|
|||
RPCOpt <$> optional confOpt
|
||||
<*> optional rpcOpt
|
||||
|
||||
pPubKey :: ReadM (PubKey 'Sign HBS2Basic)
|
||||
pPubKey :: ReadM (PubKey 'Sign 'HBS2Basic)
|
||||
pPubKey = maybeReader fromStringMay
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@ import HBS2.OrDie
|
|||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Auth.Schema
|
||||
import HBS2.Peer.Proto.LWWRef
|
||||
|
||||
import HBS2.Peer.RPC.API.LWWRef
|
||||
|
|
@ -35,8 +34,8 @@ pLwwRefFetch = do
|
|||
Left e -> err (viaShow e) >> exitFailure
|
||||
Right{} -> pure ()
|
||||
|
||||
lwwRef :: ReadM (LWWRefKey HBS2Basic)
|
||||
lwwRef = maybeReader (fromStringMay @(LWWRefKey HBS2Basic))
|
||||
lwwRef :: ReadM (LWWRefKey 'HBS2Basic)
|
||||
lwwRef = maybeReader (fromStringMay @(LWWRefKey 'HBS2Basic))
|
||||
|
||||
pLwwRefGet :: Parser (IO ())
|
||||
pLwwRefGet = do
|
||||
|
|
@ -69,7 +68,7 @@ pLwwRefUpdate = do
|
|||
Right Nothing -> err ("not found value for" <+> pretty ref) >> exitFailure
|
||||
Right (Just r) -> pure $ succ (lwwSeq r)
|
||||
|
||||
let box = makeSignedBox @L4Proto pk sk (LWWRef @L4Proto seq val Nothing)
|
||||
let box = makeSignedBox pk sk (LWWRef seq val Nothing)
|
||||
callService @RpcLWWRefUpdate caller box >>= \case
|
||||
Left e -> err (viaShow e) >> exitFailure
|
||||
Right r -> print $ pretty r
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ pRefChanHeadGen = do
|
|||
|
||||
s <- maybe1 fn getContents readFile
|
||||
hd <- pure (fromStringMay @(RefChanHeadBlock L4Proto) s) `orDie` "can't generate head block"
|
||||
let qq = makeSignedBox @L4Proto @(RefChanHeadBlock L4Proto) (view peerSignPk creds) (view peerSignSk creds) hd
|
||||
let qq = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) hd
|
||||
LBS.putStr (serialise qq)
|
||||
|
||||
pRefChanHeadDump :: Parser (IO ())
|
||||
|
|
@ -84,7 +84,7 @@ pRefChanHeadDump= do
|
|||
fn <- optional $ strArgument (metavar "refchan head blob")
|
||||
pure $ do
|
||||
lbs <- maybe1 fn LBS.getContents LBS.readFile
|
||||
(_, hdblk) <- pure (unboxSignedBox @(RefChanHeadBlock L4Proto) @L4Proto lbs) `orDie` "can't unbox signed box"
|
||||
(_, hdblk) <- pure (unboxSignedBox @(RefChanHeadBlock L4Proto) @'HBS2Basic lbs) `orDie` "can't unbox signed box"
|
||||
print $ pretty hdblk
|
||||
|
||||
|
||||
|
|
@ -130,7 +130,7 @@ pRefChanPropose = do
|
|||
|
||||
lbs <- maybe1 fn LBS.getContents LBS.readFile
|
||||
|
||||
let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs)
|
||||
let box = makeSignedBox (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs)
|
||||
|
||||
if dry then do
|
||||
LBS.putStr (serialise box)
|
||||
|
|
@ -178,15 +178,15 @@ pRefChanNotifyPost = do
|
|||
|
||||
-- caller <- ContT $ withMyRPC @RefChanAPI opts
|
||||
|
||||
sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58 @(Sigil L4Proto))
|
||||
sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58)
|
||||
`orDie` "parse sigil failed"
|
||||
|
||||
(auPk, sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil))
|
||||
(auPk, sd) <- pure (unboxSignedBox0 (sigilData sigil))
|
||||
>>= orThrowUser "malformed sigil/bad signature"
|
||||
|
||||
keys <- liftIO $ runKeymanClient do
|
||||
creds <- loadCredentials auPk >>= orThrowUser "can't load credentials"
|
||||
encKey <- loadKeyRingEntry (sigilDataEncKey sd)
|
||||
encKey <- loadKeyRingEntry (sigilDataEncKey @'HBS2Basic sd)
|
||||
pure (creds,encKey)
|
||||
|
||||
let creds = view _1 keys
|
||||
|
|
@ -253,7 +253,7 @@ pRefChanNotifyPost = do
|
|||
gks <- runExceptT (readFromMerkle sto (SimpleKey gkv))
|
||||
>>= toMPlus
|
||||
|
||||
gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gks
|
||||
gk <- deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) gks
|
||||
& toMPlus
|
||||
|
||||
notice $ "found GK0" <+> pretty gkv
|
||||
|
|
@ -263,7 +263,7 @@ pRefChanNotifyPost = do
|
|||
gk <- case mgk of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
gknew <- generateGroupKey @HBS2Basic Nothing (HashSet.toList rcpts)
|
||||
gknew <- generateGroupKey @'HBS2Basic Nothing (HashSet.toList rcpts)
|
||||
|
||||
gkh <- writeAsMerkle sto (serialise gknew)
|
||||
|
||||
|
|
@ -281,7 +281,7 @@ pRefChanNotifyPost = do
|
|||
-- FIXME: use-deterministic-nonce
|
||||
lift $ encryptBlock sto gks (Right gk) Nothing lbs <&> serialise
|
||||
|
||||
let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict ss)
|
||||
let box = makeSignedBox (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict ss)
|
||||
void $ callService @RpcRefChanNotify refChanAPI (puk, box)
|
||||
|
||||
where
|
||||
|
|
@ -368,7 +368,7 @@ pRefChanGK = do
|
|||
|
||||
let readers = view refChanHeadReaders' hd
|
||||
|
||||
gk <- generateGroupKey @HBS2Basic Nothing (HashSet.toList readers)
|
||||
gk <- generateGroupKey @'HBS2Basic Nothing (HashSet.toList readers)
|
||||
|
||||
liftIO $ print $ pretty (AsGroupKeyFile gk)
|
||||
|
||||
|
|
|
|||
|
|
@ -93,16 +93,16 @@ httpWorker (PeerConfig syn) pmeta e = do
|
|||
get "/ref/:key" do
|
||||
|
||||
void $ flip runContT pure do
|
||||
what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey HBS2Basic))
|
||||
what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey s))
|
||||
>>= orElse (status status404)
|
||||
|
||||
rv <- getRef sto what
|
||||
>>= orElse (status status404)
|
||||
>>= getBlock sto
|
||||
>>= orElse (status status404)
|
||||
<&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef e) e)
|
||||
<&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef s) s)
|
||||
>>= orElse (status status404)
|
||||
<&> unboxSignedBox0 @(LWWRef e)
|
||||
<&> unboxSignedBox0 @(LWWRef s)
|
||||
>>= orElse (status status404)
|
||||
<&> lwwValue . snd
|
||||
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ peerConfigInit mbfp = liftIO do
|
|||
appendFile cfgPath ";; hbs2-peer config file"
|
||||
appendFile cfgPath defConfigData
|
||||
|
||||
cred0 <- newCredentials @HBS2Basic
|
||||
cred0 <- newCredentials @'HBS2Basic
|
||||
let keyname = "default.key"
|
||||
let keypath = dir</>keyname
|
||||
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@ runCLI = do
|
|||
pVersion = pure do
|
||||
LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version)
|
||||
|
||||
pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic))
|
||||
pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))
|
||||
|
||||
pRun = do
|
||||
runPeer <$> common
|
||||
|
|
@ -586,7 +586,7 @@ runCLI = do
|
|||
void $ runMaybeT do
|
||||
void $ callService @RpcPerformGC caller ()
|
||||
|
||||
refP :: ReadM (PubKey 'Sign HBS2Basic)
|
||||
refP :: ReadM (PubKey 'Sign 'HBS2Basic)
|
||||
refP = maybeReader fromStringMay
|
||||
|
||||
hashP :: ReadM HashRef
|
||||
|
|
@ -1124,7 +1124,7 @@ runPeer opts = Exception.handle (\e -> myException e
|
|||
blk1 <- liftIO $ getBlock sto ha
|
||||
maybe1 blk1 none S.yield
|
||||
|
||||
let box = deserialiseOrFail @(SignedBox (RefChanHeadBlock e) e) (LBS.concat chunks)
|
||||
let box = deserialiseOrFail @(SignedBox (RefChanHeadBlock e) s) (LBS.concat chunks)
|
||||
|
||||
case box of
|
||||
-- FIXME: proper-error-handling
|
||||
|
|
|
|||
|
|
@ -131,7 +131,7 @@ type MyPeer e = ( Eq (Peer e)
|
|||
, Hashable (Peer e)
|
||||
, Pretty (Peer e)
|
||||
, HasPeer e
|
||||
, ForSignedBox e
|
||||
, ForSignedBox (Encryption e)
|
||||
)
|
||||
|
||||
data DownloadReq e
|
||||
|
|
@ -162,7 +162,7 @@ instance Expires (EventKey e (DownloadReq e)) where
|
|||
type DownloadFromPeerStuff e m = ( MyPeer e
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, ForSignedBox e
|
||||
, ForSignedBox (Encryption e)
|
||||
, Request e (BlockInfo e) m
|
||||
, Request e (BlockChunks e) m
|
||||
, MonadReader (PeerEnv e ) m
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ instance (LWWRefContext m) => HandleMethod m RpcLWWRefGet where
|
|||
runMaybeT do
|
||||
rv <- getRef sto key >>= toMPlus
|
||||
val <- getBlock sto rv >>= toMPlus
|
||||
<&> unboxSignedBox @(LWWRef L4Proto) @L4Proto
|
||||
<&> unboxSignedBox @(LWWRef 'HBS2Basic) @HBS2Basic
|
||||
>>= toMPlus
|
||||
|
||||
pure $ snd val
|
||||
|
|
@ -72,6 +72,6 @@ instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where
|
|||
liftIO $ withPeerM penv do
|
||||
me <- ownPeer @L4Proto
|
||||
runResponseM me $ do
|
||||
lwwRefProto nada (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box))
|
||||
lwwRefProto nada (LWWRefProto1 @L4Proto (LWWProtoSet (LWWRefKey puk) box))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ instance RefChanContext m => HandleMethod m RpcRefChanHeadGet where
|
|||
debug $ "rpc.refchanHeadGet:" <+> pretty (AsBase58 puk)
|
||||
liftIO $ withPeerM penv $ do
|
||||
sto <- getStorage
|
||||
liftIO $ getRef sto (RefChanHeadKey @HBS2Basic puk) <&> fmap HashRef
|
||||
liftIO $ getRef sto (RefChanHeadKey @'HBS2Basic puk) <&> fmap HashRef
|
||||
|
||||
instance (RefChanContext m) => HandleMethod m RpcRefChanHeadFetch where
|
||||
|
||||
|
|
@ -63,7 +63,7 @@ instance RefChanContext m => HandleMethod m RpcRefChanGet where
|
|||
debug $ "rpc.refchanGet:" <+> pretty (AsBase58 puk)
|
||||
liftIO $ withPeerM penv $ do
|
||||
sto <- getStorage
|
||||
liftIO $ getRef sto (RefChanLogKey @HBS2Basic puk) <&> fmap HashRef
|
||||
liftIO $ getRef sto (RefChanLogKey @'HBS2Basic puk) <&> fmap HashRef
|
||||
|
||||
instance RefChanContext m => HandleMethod m RpcRefChanPropose where
|
||||
|
||||
|
|
|
|||
|
|
@ -37,11 +37,11 @@ instance (RefLogContext m) => HandleMethod m RpcRefLogGet where
|
|||
handleMethod pk = do
|
||||
co <- getRpcContext @RefLogAPI
|
||||
debug $ "rpc.reflogGet:" <+> pretty (AsBase58 pk)
|
||||
<+> pretty (hashObject @HbSync (RefLogKey @HBS2Basic pk))
|
||||
<+> pretty (hashObject @HbSync (RefLogKey @'HBS2Basic pk))
|
||||
|
||||
liftIO $ withPeerM (rpcPeerEnv co) $ do
|
||||
let sto = rpcStorage co
|
||||
liftIO (getRef sto (RefLogKey @HBS2Basic pk)) <&> fmap HashRef
|
||||
liftIO (getRef sto (RefLogKey @'HBS2Basic pk)) <&> fmap HashRef
|
||||
|
||||
instance (RefLogContext m) => HandleMethod m RpcRefLogFetch where
|
||||
|
||||
|
|
|
|||
|
|
@ -721,7 +721,7 @@ refChanWorker env brains = do
|
|||
trace $ "BLOCK IS HERE" <+> pretty hr
|
||||
-- читаем блок
|
||||
lbs <- readBlobFromTree (getBlock sto) hr <&> fromMaybe mempty
|
||||
let what = unboxSignedBox @(RefChanHeadBlock e) @e lbs
|
||||
let what = unboxSignedBox @(RefChanHeadBlock e) @s lbs
|
||||
|
||||
notify <- atomically $ do
|
||||
no <- readTVar (_refChanWorkerEnvNotify env) <&> HashMap.member chan
|
||||
|
|
@ -742,7 +742,7 @@ refChanWorker env brains = do
|
|||
|
||||
lbss <- MaybeT $ readBlobFromTree (getBlock sto) (HashRef cur)
|
||||
|
||||
(_, blkOur) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e lbss
|
||||
(_, blkOur) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @s lbss
|
||||
|
||||
pure $ view refChanHeadVersion blkOur
|
||||
|
||||
|
|
@ -863,7 +863,7 @@ logMergeProcess penv env q = withPeerM penv do
|
|||
Just x -> pure (Just x)
|
||||
Nothing -> runMaybeT do
|
||||
hdblob <- MaybeT $ readBlobFromTree ( liftIO . getBlock sto ) h
|
||||
(_, headblk) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e hdblob
|
||||
(_, headblk) <- MaybeT $ pure $ unboxSignedBox @_ @s hdblob
|
||||
atomically $ modifyTVar (mergeHeads e) (HashMap.insert h headblk)
|
||||
pure headblk
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ common common-deps
|
|||
, dns
|
||||
, filepath
|
||||
, generic-lens
|
||||
, generic-data
|
||||
, hashable
|
||||
, microlens-platform
|
||||
, mtl
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ deriving newtype instance ForRefChans e => Hashable (NotifyKey (RefChanEvents e)
|
|||
deriving newtype instance ForRefChans e => Eq (NotifyKey (RefChanEvents e))
|
||||
|
||||
data instance NotifyData (RefChanEvents e) =
|
||||
RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString e)
|
||||
RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString (Encryption e))
|
||||
deriving Generic
|
||||
|
||||
instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e))
|
||||
|
|
|
|||
|
|
@ -148,7 +148,7 @@ instance HasProtocol L4Proto (RefChanNotify L4Proto) where
|
|||
-- возьмем пока 10 секунд
|
||||
requestPeriodLim = NoLimit
|
||||
|
||||
instance ForLWWRefProto L4Proto => HasProtocol L4Proto (LWWRefProto L4Proto) where
|
||||
instance HasProtocol L4Proto (LWWRefProto L4Proto) where
|
||||
type instance ProtocolId (LWWRefProto L4Proto) = 12001
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
|
|
|
|||
|
|
@ -8,13 +8,10 @@ import HBS2.Base58
|
|||
import HBS2.Storage
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Net.Auth.Schema()
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Hashable hiding (Hashed)
|
||||
import Data.Maybe
|
||||
import Data.Word
|
||||
|
|
@ -22,17 +19,17 @@ import Control.Monad.Trans.Maybe
|
|||
import Control.Monad.Except
|
||||
import Codec.Serialise
|
||||
|
||||
data LWWRefProtoReq e =
|
||||
LWWProtoGet (LWWRefKey (Encryption e))
|
||||
| LWWProtoSet (LWWRefKey (Encryption e)) (SignedBox (LWWRef e) e)
|
||||
data LWWRefProtoReq (s :: CryptoScheme) =
|
||||
LWWProtoGet (LWWRefKey s)
|
||||
| LWWProtoSet (LWWRefKey s) (SignedBox (LWWRef s) s)
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
data LWWRefProto e =
|
||||
LWWRefProto1 (LWWRefProtoReq e)
|
||||
LWWRefProto1 (LWWRefProtoReq (Encryption e))
|
||||
deriving stock (Generic)
|
||||
|
||||
data LWWRef e =
|
||||
data LWWRef (s :: CryptoScheme) =
|
||||
LWWRef
|
||||
{ lwwSeq :: Word64
|
||||
, lwwValue :: HashRef
|
||||
|
|
@ -40,12 +37,14 @@ data LWWRef e =
|
|||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
-- FIXME: move-to-a-right-place
|
||||
-- deriving instance Data e => Data (LWWRef e)
|
||||
|
||||
type ForLWWRefProto e = (ForSignedBox e, Serialise (LWWRefKey (Encryption e)))
|
||||
type ForLWWRefProto (s :: CryptoScheme) = (ForSignedBox s, Serialise (LWWRefKey s))
|
||||
|
||||
instance ForLWWRefProto e => Serialise (LWWRefProtoReq e)
|
||||
instance ForLWWRefProto e => Serialise (LWWRefProto e)
|
||||
instance ForLWWRefProto e => Serialise (LWWRef e)
|
||||
instance ForLWWRefProto s => Serialise (LWWRefProtoReq s)
|
||||
instance ForLWWRefProto (Encryption e) => Serialise (LWWRefProto e)
|
||||
instance ForLWWRefProto s => Serialise (LWWRef s)
|
||||
|
||||
newtype LWWRefKey s =
|
||||
LWWRefKey
|
||||
|
|
@ -96,42 +95,40 @@ data ReadLWWRefError =
|
|||
| ReadLWWSignatureError
|
||||
deriving stock (Show,Typeable)
|
||||
|
||||
readLWWRef :: forall e s m . ( MonadIO m
|
||||
, MonadError ReadLWWRefError m
|
||||
, Encryption e ~ s
|
||||
, ForLWWRefProto e
|
||||
, Signatures s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
readLWWRef :: forall s m . ( MonadIO m
|
||||
, MonadError ReadLWWRefError m
|
||||
, ForLWWRefProto s
|
||||
, Signatures s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
=> AnyStorage
|
||||
-> LWWRefKey s
|
||||
-> m (Maybe (LWWRef e))
|
||||
-> m (Maybe (LWWRef s))
|
||||
|
||||
readLWWRef sto key = runMaybeT do
|
||||
getRef sto key
|
||||
>>= toMPlus
|
||||
>>= getBlock sto
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @(SignedBox (LWWRef e) e)
|
||||
<&> deserialiseOrFail @(SignedBox (LWWRef s) s)
|
||||
>>= orThrowError ReadLWWFormatError
|
||||
<&> unboxSignedBox0
|
||||
>>= orThrowError ReadLWWSignatureError
|
||||
<&> snd
|
||||
|
||||
updateLWWRef :: forall s e m . ( Encryption e ~ s
|
||||
, ForLWWRefProto e
|
||||
, MonadIO m
|
||||
, Signatures s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
updateLWWRef :: forall s m . ( ForLWWRefProto s
|
||||
, MonadIO m
|
||||
, Signatures s
|
||||
, IsRefPubKey s
|
||||
)
|
||||
=> AnyStorage
|
||||
-> LWWRefKey s
|
||||
-> PrivKey 'Sign s
|
||||
-> LWWRef e
|
||||
-> LWWRef s
|
||||
-> m (Maybe HashRef)
|
||||
|
||||
updateLWWRef sto k sk v = do
|
||||
let box = makeSignedBox @e (fromLwwRefKey k) sk v
|
||||
let box = makeSignedBox @s (fromLwwRefKey k) sk v
|
||||
runMaybeT do
|
||||
hx <- putBlock sto (serialise box) >>= toMPlus
|
||||
updateRef sto k hx
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ data LWWRefProtoAdapter e m =
|
|||
}
|
||||
|
||||
lwwRefProto :: forall e s m proto . ( MonadIO m
|
||||
, ForLWWRefProto e
|
||||
, ForLWWRefProto s
|
||||
, Request e proto m
|
||||
, Response e proto m
|
||||
, HasDeferred proto e m
|
||||
|
|
@ -66,7 +66,7 @@ lwwRefProto adapter pkt@(LWWRefProto1 req) = do
|
|||
<&> deserialiseOrFail
|
||||
>>= toMPlus
|
||||
|
||||
lift $ response (LWWRefProto1 (LWWProtoSet @e key box))
|
||||
lift $ response (LWWRefProto1 @e (LWWProtoSet key box))
|
||||
|
||||
LWWProtoSet key box -> void $ runMaybeT do
|
||||
|
||||
|
|
@ -97,7 +97,7 @@ lwwRefProto adapter pkt@(LWWRefProto1 req) = do
|
|||
blk' <- getBlock sto rv
|
||||
maybe1 blk' (forcedUpdateLwwRef sto key bs) $ \blk -> do
|
||||
|
||||
let lww0 = deserialiseOrFail @(SignedBox (LWWRef e) e) blk
|
||||
let lww0 = deserialiseOrFail @(SignedBox (LWWRef s) s) blk
|
||||
& either (const Nothing) Just
|
||||
>>= unboxSignedBox0
|
||||
<&> snd
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
|
|||
|
||||
import UnliftIO
|
||||
|
||||
data ProposeTran e = ProposeTran HashRef (SignedBox ByteString e) -- произвольная бинарная транзакция,
|
||||
data ProposeTran e = ProposeTran HashRef (SignedBox ByteString (Encryption e)) -- произвольная бинарная транзакция,
|
||||
deriving stock (Generic) -- подписанная ключом **АВТОРА**, который её рассылает
|
||||
|
||||
newtype AcceptTime = AcceptTime Word64
|
||||
|
|
@ -126,8 +126,8 @@ instance Expires (EventKey e (RefChanRound e)) where
|
|||
-- черт его знает, какой там останется пайлоад.
|
||||
-- надо посмотреть. байт, небось, 400
|
||||
data RefChanUpdate e =
|
||||
Propose (RefChanId e) (SignedBox (ProposeTran e) e) -- подписано ключом пира
|
||||
| Accept (RefChanId e) (SignedBox (AcceptTran e) e) -- подписано ключом пира
|
||||
Propose (RefChanId e) (SignedBox (ProposeTran e) (Encryption e)) -- подписано ключом пира
|
||||
| Accept (RefChanId e) (SignedBox (AcceptTran e) (Encryption e)) -- подписано ключом пира
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForRefChans e => Serialise (RefChanUpdate e)
|
||||
|
|
@ -381,7 +381,7 @@ refChanUpdateProto self pc adapter msg = do
|
|||
let tran = AcceptTran ts headRef (HashRef hash)
|
||||
|
||||
-- -- генерируем Accept
|
||||
let accept = Accept chan (makeSignedBox @e pk sk tran)
|
||||
let accept = Accept chan (makeSignedBox @s pk sk tran)
|
||||
|
||||
-- -- и рассылаем всем
|
||||
debug "GOSSIP ACCEPT TRANSACTION"
|
||||
|
|
@ -443,7 +443,7 @@ refChanUpdateProto self pc adapter msg = do
|
|||
_ -> Nothing
|
||||
|
||||
|
||||
(_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed
|
||||
(_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @s proposed
|
||||
|
||||
debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0
|
||||
|
||||
|
|
@ -572,8 +572,8 @@ makeProposeTran :: forall e s m . ( MonadIO m
|
|||
)
|
||||
=> PeerCredentials s
|
||||
-> RefChanId e
|
||||
-> SignedBox ByteString e
|
||||
-> m (Maybe (SignedBox (ProposeTran e) e))
|
||||
-> SignedBox ByteString s
|
||||
-> m (Maybe (SignedBox (ProposeTran e) s))
|
||||
|
||||
makeProposeTran creds chan box1 = do
|
||||
sto <- getStorage
|
||||
|
|
@ -582,7 +582,7 @@ makeProposeTran creds chan box1 = do
|
|||
let tran = ProposeTran @e (HashRef h) box1
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
pure $ makeSignedBox @e pk sk tran
|
||||
pure $ makeSignedBox @s pk sk tran
|
||||
|
||||
-- FIXME: reconnect-validator-client-after-restart
|
||||
-- почему-то сейчас если рестартовать пира,
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ data RefChanActionRequest =
|
|||
instance Serialise RefChanActionRequest
|
||||
|
||||
data RefChanNotify e =
|
||||
Notify (RefChanId e) (SignedBox ByteString e) -- подписано ключом автора
|
||||
Notify (RefChanId e) (SignedBox ByteString (Encryption e)) -- подписано ключом автора
|
||||
-- довольно уместно будет добавить эти команды сюда -
|
||||
-- они постоянно нужны, и это сильно упростит коммуникации
|
||||
| ActionRequest (RefChanId e) RefChanActionRequest
|
||||
|
|
@ -128,7 +128,6 @@ type ForRefChans e = ( Serialise ( PubKey 'Sign (Encryption e))
|
|||
)
|
||||
|
||||
|
||||
|
||||
refChanHeadReaders :: ForRefChans e
|
||||
=> Lens (RefChanHeadBlock e)
|
||||
(RefChanHeadBlock e)
|
||||
|
|
@ -367,7 +366,7 @@ getRefChanHead :: forall e s m . ( MonadIO m
|
|||
getRefChanHead sto k = runMaybeT do
|
||||
h <- MaybeT $ liftIO $ getRef sto k
|
||||
hdblob <- MaybeT $ readBlobFromTree ( getBlock sto ) (HashRef h)
|
||||
(_, headblk) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e hdblob
|
||||
(_, headblk) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @s hdblob
|
||||
pure headblk
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@ import HBS2.Peer.Prelude
|
|||
import HBS2.Peer.Proto.LWWRef
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Data.Types.Refs (HashRef(..))
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Peer.Proto.RefLog (RefLogUpdate)
|
||||
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Codec.Serialise
|
||||
|
|
@ -26,13 +24,13 @@ instance HasProtocol UNIX (ServiceProto LWWRefAPI UNIX) where
|
|||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
type instance Input RpcLWWRefGet = LWWRefKey HBS2Basic
|
||||
type instance Output RpcLWWRefGet = Maybe (LWWRef L4Proto)
|
||||
type instance Input RpcLWWRefGet = LWWRefKey 'HBS2Basic
|
||||
type instance Output RpcLWWRefGet = Maybe (LWWRef 'HBS2Basic)
|
||||
|
||||
type instance Input RpcLWWRefFetch = LWWRefKey HBS2Basic
|
||||
type instance Input RpcLWWRefFetch = LWWRefKey 'HBS2Basic
|
||||
type instance Output RpcLWWRefFetch = ()
|
||||
|
||||
type instance Input RpcLWWRefUpdate = SignedBox (LWWRef L4Proto) L4Proto
|
||||
type instance Input RpcLWWRefUpdate = SignedBox (LWWRef 'HBS2Basic) 'HBS2Basic
|
||||
type instance Output RpcLWWRefUpdate = ()
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -79,13 +79,13 @@ type instance Input RpcPexInfo = ()
|
|||
type instance Output RpcPexInfo = [PeerAddr L4Proto]
|
||||
|
||||
type instance Input RpcPeers = ()
|
||||
type instance Output RpcPeers = [(PubKey 'Sign HBS2Basic, PeerAddr L4Proto)]
|
||||
type instance Output RpcPeers = [(PubKey 'Sign 'HBS2Basic, PeerAddr L4Proto)]
|
||||
|
||||
type instance Input RpcFetch = HashRef
|
||||
type instance Output RpcFetch = ()
|
||||
|
||||
type instance Input RpcPollList= ()
|
||||
type instance Output RpcPollList = [(PubKey 'Sign HBS2Basic, String, Int)]
|
||||
type instance Output RpcPollList = [(PubKey 'Sign 'HBS2Basic, String, Int)]
|
||||
|
||||
type instance Input RpcDownloadList = ()
|
||||
type instance Output RpcDownloadList = [(HashRef, Integer)]
|
||||
|
|
@ -93,10 +93,10 @@ type instance Output RpcDownloadList = [(HashRef, Integer)]
|
|||
type instance Input RpcDownloadDel = HashRef
|
||||
type instance Output RpcDownloadDel = ()
|
||||
|
||||
type instance Input RpcPollAdd = (PubKey 'Sign HBS2Basic, String, Int)
|
||||
type instance Input RpcPollAdd = (PubKey 'Sign 'HBS2Basic, String, Int)
|
||||
type instance Output RpcPollAdd = ()
|
||||
|
||||
type instance Input RpcPollDel = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcPollDel = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcPollDel = ()
|
||||
|
||||
type instance Input RpcLogLevel = SetLogging
|
||||
|
|
|
|||
|
|
@ -43,22 +43,22 @@ instance HasProtocol UNIX (ServiceProto RefChanAPI UNIX) where
|
|||
encode = serialise
|
||||
|
||||
|
||||
type instance Input RpcRefChanHeadGet = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcRefChanHeadGet = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcRefChanHeadGet = Maybe HashRef
|
||||
|
||||
type instance Input RpcRefChanHeadFetch = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcRefChanHeadFetch = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcRefChanHeadFetch = ()
|
||||
|
||||
type instance Input RpcRefChanFetch = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcRefChanFetch = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcRefChanFetch = ()
|
||||
|
||||
type instance Input RpcRefChanGet = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcRefChanGet = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcRefChanGet = Maybe HashRef
|
||||
|
||||
type instance Input RpcRefChanPropose = (PubKey 'Sign HBS2Basic, SignedBox BS.ByteString L4Proto)
|
||||
type instance Input RpcRefChanPropose = (PubKey 'Sign 'HBS2Basic, SignedBox BS.ByteString 'HBS2Basic)
|
||||
type instance Output RpcRefChanPropose = ()
|
||||
|
||||
type instance Input RpcRefChanNotify = (PubKey 'Sign HBS2Basic, SignedBox BS.ByteString L4Proto)
|
||||
type instance Input RpcRefChanNotify = (PubKey 'Sign 'HBS2Basic, SignedBox BS.ByteString 'HBS2Basic)
|
||||
type instance Output RpcRefChanNotify = ()
|
||||
|
||||
type instance Input RpcRefChanHeadPost = HashRef
|
||||
|
|
|
|||
|
|
@ -27,10 +27,10 @@ instance HasProtocol UNIX (ServiceProto RefLogAPI UNIX) where
|
|||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
type instance Input RpcRefLogGet = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcRefLogGet = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcRefLogGet = Maybe HashRef
|
||||
|
||||
type instance Input RpcRefLogFetch = PubKey 'Sign HBS2Basic
|
||||
type instance Input RpcRefLogFetch = PubKey 'Sign 'HBS2Basic
|
||||
type instance Output RpcRefLogFetch = ()
|
||||
|
||||
type instance Input RpcRefLogPost = RefLogUpdate L4Proto
|
||||
|
|
|
|||
|
|
@ -36,8 +36,8 @@ data RPC2Context =
|
|||
, rpcByPassInfo :: IO ByPassStat
|
||||
, rpcDoFetch :: HashRef -> IO ()
|
||||
, rpcDoRefChanHeadPost :: HashRef -> IO ()
|
||||
, rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO ()
|
||||
, rpcDoRefChanNotify :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO ()
|
||||
, rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
|
||||
, rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
|
||||
}
|
||||
|
||||
instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where
|
||||
|
|
|
|||
|
|
@ -50,17 +50,17 @@ testVersionedKeysHashes = do
|
|||
& orThrowUser "bad base58"
|
||||
<&> LBS.fromStrict
|
||||
|
||||
pk <- fromStringMay @(PubKey 'Sign HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
|
||||
pk <- fromStringMay @(PubKey 'Sign 'HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
|
||||
& orThrowUser "key decode"
|
||||
|
||||
let pks = serialise pk
|
||||
|
||||
pks2 <- deserialiseOrFail @(PubKey 'Sign HBS2Basic) (pks <> "12345")
|
||||
pks2 <- deserialiseOrFail @(PubKey 'Sign 'HBS2Basic) (pks <> "12345")
|
||||
& orThrowUser "key decode error"
|
||||
|
||||
let rfk = serialise (RefLogKey @HBS2Basic pk)
|
||||
let wrfk = serialise $ W (RefLogKey @HBS2Basic pk)
|
||||
let xrfk = serialise $ X (RefLogKey @HBS2Basic pk)
|
||||
let rfk = serialise (RefLogKey @'HBS2Basic pk)
|
||||
let wrfk = serialise $ W (RefLogKey @'HBS2Basic pk)
|
||||
let xrfk = serialise $ X (RefLogKey @'HBS2Basic pk)
|
||||
|
||||
print $ pretty (AsHexSparse keypart)
|
||||
print $ pretty (AsHexSparse pks)
|
||||
|
|
|
|||
|
|
@ -169,8 +169,8 @@ makeGK0Key rpc = runMaybeT do
|
|||
|
||||
getGK0 :: forall e s m . ( AppPerks m
|
||||
, HasProtocol e (ServiceProto StorageAPI e)
|
||||
, ForGroupKeySymm HBS2Basic
|
||||
, s ~ HBS2Basic
|
||||
, ForGroupKeySymm 'HBS2Basic
|
||||
, s ~ 'HBS2Basic
|
||||
)
|
||||
=> RpcEndpoints e
|
||||
-> ShareCLI m (GK0 s)
|
||||
|
|
@ -273,10 +273,9 @@ withRpcClientUnix action = do
|
|||
pure r
|
||||
|
||||
|
||||
loadSigil :: forall e s m . ( s ~ Encryption e
|
||||
, ForSigil e
|
||||
, AppPerks m
|
||||
) => ShareCLI m (PubKey 'Sign s, SigilData e)
|
||||
loadSigil :: forall s m . ( ForSigil s
|
||||
, AppPerks m
|
||||
) => ShareCLI m (PubKey 'Sign s, SigilData s)
|
||||
loadSigil = do
|
||||
|
||||
dir <- getLocalConfigDir
|
||||
|
|
@ -293,10 +292,10 @@ loadSigil = do
|
|||
|
||||
trace $ "SIGIL PATH" <+> pretty path
|
||||
|
||||
sigil <- liftIO $ (BS.readFile path <&> parseSerialisableFromBase58 @(Sigil e))
|
||||
sigil <- liftIO $ (BS.readFile path <&> parseSerialisableFromBase58 @(Sigil s))
|
||||
>>= orThrowUser ("invalid sigil format" <+> pretty path)
|
||||
|
||||
w@(_,sd) <- orThrowUser "malformed sigil" (unboxSignedBox0 @(SigilData e) (sigilData sigil))
|
||||
w@(_,sd) <- orThrowUser "malformed sigil" (unboxSignedBox0 @(SigilData s) (sigilData sigil))
|
||||
|
||||
pure w
|
||||
|
||||
|
|
@ -304,7 +303,7 @@ loadAllEncryptionStuff :: AppPerks m => ShareCLI m ()
|
|||
loadAllEncryptionStuff = do
|
||||
|
||||
-- 1. загружаем sigil
|
||||
(pk, sd) <- loadSigil @L4Proto
|
||||
(pk, sd) <- loadSigil @'HBS2Basic
|
||||
|
||||
trace $ "sigil loaded" <+> pretty (AsBase58 pk)
|
||||
|
||||
|
|
@ -640,7 +639,7 @@ updateLocalState = do
|
|||
postState :: forall e s m . ( AppPerks m
|
||||
, HasProtocol e (ServiceProto RefChanAPI e)
|
||||
, HasProtocol e (ServiceProto StorageAPI e)
|
||||
, s ~ HBS2Basic
|
||||
, s ~ 'HBS2Basic
|
||||
)
|
||||
|
||||
=> RpcEndpoints e
|
||||
|
|
@ -755,7 +754,7 @@ postState rpc px = do
|
|||
let ssk = view (creds . peerSignSk) encStuff
|
||||
let spk = view (creds . peerSignPk) encStuff
|
||||
|
||||
let box = makeSignedBox @L4Proto @BS.ByteString spk ssk (LBS.toStrict $ serialise tx)
|
||||
let box = makeSignedBox spk ssk (LBS.toStrict $ serialise tx)
|
||||
|
||||
dont <- lift dontPost
|
||||
|
||||
|
|
@ -765,7 +764,7 @@ postState rpc px = do
|
|||
pure ()
|
||||
|
||||
where
|
||||
-- genTreeOverride :: AnyStorage -> EncryptionStuff -> GK0 HBS2Basic -> HashRef -> m ()
|
||||
-- genTreeOverride :: AnyStorage -> EncryptionStuff -> GK0 'HBS2Basic -> HashRef -> m ()
|
||||
genTreeOverride sto enc gk0 tree = do
|
||||
let (KeyringKeys pk sk) = view kre enc
|
||||
runMaybeT do
|
||||
|
|
@ -819,7 +818,7 @@ runSync = do
|
|||
updateLocalState
|
||||
postState rpc px
|
||||
|
||||
writeEncryptedFile :: forall m s nonce . (MonadIO m, Serialise nonce, s ~ HBS2Basic)
|
||||
writeEncryptedFile :: forall m s nonce . (MonadIO m, Serialise nonce, s ~ 'HBS2Basic)
|
||||
=> GroupSecret
|
||||
-> GroupKey 'Symm s
|
||||
-> AnyStorage
|
||||
|
|
|
|||
|
|
@ -54,8 +54,8 @@ data RpcEndpoints e =
|
|||
|
||||
data EncryptionStuff =
|
||||
EncryptionStuff
|
||||
{ _creds :: PeerCredentials HBS2Basic
|
||||
, _kre :: KeyringEntry HBS2Basic
|
||||
{ _creds :: PeerCredentials 'HBS2Basic
|
||||
, _kre :: KeyringEntry 'HBS2Basic
|
||||
}
|
||||
|
||||
makeLenses ''EncryptionStuff
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ main = do
|
|||
<> header "Raw tx test"
|
||||
)
|
||||
krData <- BS.readFile $ credentialsFile options
|
||||
creds <- pure (parseCredentials @HBS2Basic (AsCredFile krData)) `orDie` "bad keyring file"
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile krData)) `orDie` "bad keyring file"
|
||||
let pubk = view peerSignPk creds
|
||||
let privk = view peerSignSk creds
|
||||
bs <- pure (fromBase58 $ BS8.pack $ tx options) `orDie` "transaction is not in Base58 format"
|
||||
|
|
|
|||
68
hbs2/Main.hs
68
hbs2/Main.hs
|
|
@ -110,7 +110,7 @@ newtype OptGroupkeyFile = OptGroupkeyFile { unOptGroupkeyFile :: FilePath }
|
|||
deriving newtype (Eq,Ord,IsString)
|
||||
deriving stock (Data)
|
||||
|
||||
newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt HBS2Basic }
|
||||
newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt 'HBS2Basic }
|
||||
deriving newtype (Eq,Ord)
|
||||
deriving stock (Data)
|
||||
|
||||
|
|
@ -151,8 +151,8 @@ newtype NewRefOpts =
|
|||
deriving stock (Data)
|
||||
|
||||
|
||||
data EncSchema = EncSymm (GroupKey 'Symm HBS2Basic)
|
||||
| EncAsymm (GroupKey 'Asymm HBS2Basic)
|
||||
data EncSchema = EncSymm (GroupKey 'Symm 'HBS2Basic)
|
||||
| EncAsymm (GroupKey 'Asymm 'HBS2Basic)
|
||||
|
||||
|
||||
hPrint :: (MonadIO m, Show a) => Handle -> a -> m ()
|
||||
|
|
@ -183,7 +183,7 @@ runHash opts _ = do
|
|||
withBinaryFile (hashFp opts) ReadMode $ \h -> do
|
||||
LBS.hGetContents h >>= print . pretty . hashObject @HbSync
|
||||
|
||||
runCat :: forall s . ForHBS2Basic s => CatOpts -> SimpleStorage HbSync -> IO ()
|
||||
runCat :: forall s . For'HBS2Basic s => CatOpts -> SimpleStorage HbSync -> IO ()
|
||||
|
||||
runCat opts ss | catRaw opts == Just True = do
|
||||
|
||||
|
|
@ -242,7 +242,7 @@ runCat opts ss = do
|
|||
keyring <- case uniLastMay @OptKeyringFile opts of
|
||||
Just krf -> do
|
||||
s <- BS.readFile (unOptKeyringFile krf)
|
||||
cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
|
||||
cred <- pure (parseCredentials @'HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
|
||||
pure $ view peerKeyring cred
|
||||
|
||||
Nothing -> fromMaybe mempty <$> runMaybeT do
|
||||
|
|
@ -319,7 +319,7 @@ runStore opts ss = runResourceT do
|
|||
|
||||
Just gkfile -> do
|
||||
|
||||
gkSymm <- liftIO $ Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile)
|
||||
gkSymm <- liftIO $ Symm.parseGroupKey @'HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile)
|
||||
|
||||
let mbGk = EncSymm <$> gkSymm
|
||||
|
||||
|
|
@ -331,7 +331,7 @@ runStore opts ss = runResourceT do
|
|||
krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set"
|
||||
|
||||
s <- liftIO $ BS.readFile (unOptKeyringFile krf)
|
||||
cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
|
||||
cred <- pure (parseCredentials @'HBS2Basic (AsCredFile s)) `orDie` "bad keyring file"
|
||||
|
||||
sk <- pure (headMay [ (view krPk k, view krSk k)
|
||||
| k <- view peerKeyring cred
|
||||
|
|
@ -380,7 +380,7 @@ runStore opts ss = runResourceT do
|
|||
|
||||
hPrint stdout $ "merkle-ann-root: " <+> pretty mannh
|
||||
|
||||
runNewGroupKeyAsymm :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
|
||||
runNewGroupKeyAsymm :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO ()
|
||||
runNewGroupKeyAsymm pubkeysFile = do
|
||||
s <- BS.readFile pubkeysFile
|
||||
pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file"
|
||||
|
|
@ -389,20 +389,20 @@ runNewGroupKeyAsymm pubkeysFile = do
|
|||
List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk
|
||||
print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey
|
||||
|
||||
runNewKey :: forall s . (s ~ HBS2Basic) => Int -> IO ()
|
||||
runNewKey :: forall s . (s ~ 'HBS2Basic) => Int -> IO ()
|
||||
runNewKey n = do
|
||||
cred0 <- newCredentials @s
|
||||
cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
|
||||
print $ pretty $ AsCredFile $ AsBase58 cred
|
||||
|
||||
runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
|
||||
runListKeys :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO ()
|
||||
runListKeys fp = do
|
||||
s <- BS.readFile fp
|
||||
cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file"
|
||||
print $ pretty (ListKeyringKeys cred)
|
||||
|
||||
|
||||
runKeyAdd :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
|
||||
runKeyAdd :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO ()
|
||||
runKeyAdd fp = do
|
||||
hPrint stderr $ "adding a key into keyring" <+> pretty fp
|
||||
s <- BS.readFile fp
|
||||
|
|
@ -410,7 +410,7 @@ runKeyAdd fp = do
|
|||
credNew <- addKeyPair Nothing cred
|
||||
print $ pretty $ AsCredFile $ AsBase58 credNew
|
||||
|
||||
runKeyDel :: forall s . (s ~ HBS2Basic) => String -> FilePath -> IO ()
|
||||
runKeyDel :: forall s . (s ~ 'HBS2Basic) => String -> FilePath -> IO ()
|
||||
runKeyDel n fp = do
|
||||
hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp
|
||||
s <- BS.readFile fp
|
||||
|
|
@ -419,7 +419,7 @@ runKeyDel n fp = do
|
|||
print $ pretty $ AsCredFile $ AsBase58 credNew
|
||||
|
||||
|
||||
runShowPeerKey :: forall s . ( s ~ HBS2Basic) => Maybe FilePath -> IO ()
|
||||
runShowPeerKey :: forall s . ( s ~ 'HBS2Basic) => Maybe FilePath -> IO ()
|
||||
runShowPeerKey fp = do
|
||||
handle <- maybe (pure stdin) (`openFile` ReadMode) fp
|
||||
bs <- LBS.hGet handle 4096 <&> LBS.toStrict
|
||||
|
|
@ -541,7 +541,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
|
||||
epk :: ReadM OptEncPubKey
|
||||
epk = eitherReader $ \arg -> do
|
||||
let mpk = fromStringMay @(PubKey 'Encrypt HBS2Basic) arg
|
||||
let mpk = fromStringMay @(PubKey 'Encrypt 'HBS2Basic) arg
|
||||
maybe1 mpk (Left "invalid public key") (pure . OptEncPubKey)
|
||||
|
||||
pCat = do
|
||||
|
|
@ -641,24 +641,24 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pure $ do
|
||||
members <- for fns $ \fn -> do
|
||||
|
||||
sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil L4Proto))
|
||||
sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil 'HBS2Basic))
|
||||
`orDie` "parse sigil failed"
|
||||
(_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil))
|
||||
(_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
|
||||
`orDie` ("signature check failed " <> fn)
|
||||
|
||||
pure (sigilDataEncKey sd)
|
||||
|
||||
gk <- Symm.generateGroupKey @HBS2Basic Nothing members
|
||||
gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
|
||||
print $ pretty (AsGroupKeyFile gk)
|
||||
|
||||
pGroupKeyFromKeys = do
|
||||
pure $ do
|
||||
input <- getContents <&> words
|
||||
members <- for input $ \s -> do
|
||||
fromStringMay @(PubKey 'Encrypt HBS2Basic) s
|
||||
fromStringMay @(PubKey 'Encrypt 'HBS2Basic) s
|
||||
& maybe (die "invalid public key") pure
|
||||
|
||||
gk <- Symm.generateGroupKey @HBS2Basic Nothing members
|
||||
gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
|
||||
print $ pretty (AsGroupKeyFile gk)
|
||||
|
||||
|
||||
|
|
@ -667,18 +667,18 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pure $ do
|
||||
syn <- maybe1 fn getContents readFile <&> parseTop <&> fromRight mempty
|
||||
|
||||
let members = [ fromStringMay @(PubKey 'Encrypt HBS2Basic) (Text.unpack s)
|
||||
let members = [ fromStringMay @(PubKey 'Encrypt 'HBS2Basic) (Text.unpack s)
|
||||
| (ListVal (Key "member" [LitStrVal s]) ) <- syn
|
||||
] & catMaybes
|
||||
|
||||
gk <- Symm.generateGroupKey @HBS2Basic Nothing members
|
||||
gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
|
||||
print $ pretty (AsGroupKeyFile gk)
|
||||
|
||||
pGroupKeySymmDump = do
|
||||
fn <- optional $ strArgument ( metavar "FILE" <> help "group key file" )
|
||||
pure $ do
|
||||
gk <- ( maybe1 fn LBS.getContents LBS.readFile
|
||||
<&> Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file"
|
||||
<&> Symm.parseGroupKey @'HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file"
|
||||
|
||||
print $ pretty gk
|
||||
|
||||
|
|
@ -695,7 +695,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
|
||||
gk <- ( LBS.readFile fn
|
||||
<&> Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file"
|
||||
<&> Symm.parseGroupKey @'HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file"
|
||||
|
||||
let keys = [ (view krPk x, view krSk x) | x <- view peerKeyring creds ]
|
||||
|
||||
|
|
@ -706,13 +706,13 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
syn <- readFile dsl <&> parseTop <&> fromRight mempty
|
||||
|
||||
-- FIXME: fix-code-dup-members
|
||||
let members = [ fromStringMay @(PubKey 'Encrypt HBS2Basic) (Text.unpack s)
|
||||
let members = [ fromStringMay @(PubKey 'Encrypt 'HBS2Basic) (Text.unpack s)
|
||||
| (ListVal (Key "member" [LitStrVal s]) ) <- syn
|
||||
] & catMaybes
|
||||
|
||||
debug $ vcat (fmap (pretty.AsBase58) members)
|
||||
|
||||
gkNew <- Symm.generateGroupKey @HBS2Basic (Just gsec) members
|
||||
gkNew <- Symm.generateGroupKey @'HBS2Basic (Just gsec) members
|
||||
print $ pretty (AsGroupKeyFile gkNew)
|
||||
|
||||
pHash = do
|
||||
|
|
@ -758,7 +758,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pRefLogGet = do
|
||||
o <- common
|
||||
reflogs <- strArgument ( metavar "REFLOG" )
|
||||
pure $ withStore o (runRefLogGet @HBS2Basic reflogs)
|
||||
pure $ withStore o (runRefLogGet @'HBS2Basic reflogs)
|
||||
|
||||
|
||||
pAnyRef = hsubparser ( command "get" (info pAnyRefGet (progDesc "get anyref value") )
|
||||
|
|
@ -768,7 +768,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pAnyRefGet = do
|
||||
o <- common
|
||||
anyref <- strArgument ( metavar "ANYREF" )
|
||||
pure $ withStore o (runAnyRefGet @HBS2Basic anyref)
|
||||
pure $ withStore o (runAnyRefGet @'HBS2Basic anyref)
|
||||
|
||||
pAnyRefSet = do
|
||||
o <- common
|
||||
|
|
@ -776,7 +776,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
val <- strArgument ( metavar "HASHREF" )
|
||||
pure $ do
|
||||
hr <- pure (fromStringMay val) `orDie` "bad HASHREF"
|
||||
withStore o (runAnyRefSet @HBS2Basic anyref hr)
|
||||
withStore o (runAnyRefSet @'HBS2Basic anyref hr)
|
||||
|
||||
pFsck = do
|
||||
o <- common
|
||||
|
|
@ -871,7 +871,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
|
||||
ref <- pure (fromStringMay hash) `orDie` "invalid HASHREF"
|
||||
|
||||
let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref)
|
||||
let refval = makeBundleRefValue @'HBS2Basic pk sk (BundleRefSimple ref)
|
||||
|
||||
mh <- putBlock sto (serialise refval)
|
||||
|
||||
|
|
@ -927,9 +927,9 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
fn <- optional $ strArgument ( metavar "SIGIL-FILE" )
|
||||
pure $ do
|
||||
handle <- maybe1 fn (pure stdin) (flip openFile ReadMode)
|
||||
sigil <- (BS.hGetContents handle <&> parseSerialisableFromBase58 @(Sigil L4Proto))
|
||||
sigil <- (BS.hGetContents handle <&> parseSerialisableFromBase58 @(Sigil 'HBS2Basic))
|
||||
`orDie` "parse sigil failed"
|
||||
(_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil))
|
||||
(_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
|
||||
`orDie` "signature check failed"
|
||||
print $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd]))
|
||||
|
||||
|
|
@ -941,8 +941,8 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pk <- argument ppk (metavar "PUBKEY")
|
||||
pure $ do
|
||||
sc <- BS.readFile krf
|
||||
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
sigil <- pure (makeSigilFromCredentials @L4Proto creds pk txt href)
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
sigil <- pure (makeSigilFromCredentials @'HBS2Basic creds pk txt href)
|
||||
`orDie` "public key not found in credentials file"
|
||||
print $ pretty (AsBase58 sigil)
|
||||
|
||||
|
|
@ -950,7 +950,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
phref = maybeReader fromStringMay
|
||||
|
||||
|
||||
pPubKey = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic))
|
||||
pPubKey = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue