voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

massive type rafactoring

This commit is contained in:
Dmitry Zuikov 2024-04-12 12:19:50 +03:00
parent 5effcebfee
commit ba7cc35bbc
60 changed files with 532 additions and 451 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
examples/refchan-qblf/app/RefChanQBLFMain.hs
View File

@ -70,7 +70,7 @@ data DefStateOpt
data StateRefOpt data StateRefOpt
data QBLFRefKey data QBLFRefKey
type MyRefKey = AnyRefKey QBLFRefKey HBS2Basic type MyRefKey = AnyRefKey QBLFRefKey 'HBS2Basic
instance Monad m => HasCfgKey HttpPortOpt (Maybe Int) m where instance Monad m => HasCfgKey HttpPortOpt (Maybe Int) m where
key = "http" key = "http"
@ -98,8 +98,8 @@ instance Monad m => HasCfgKey DefStateOpt (Maybe String) m where
instance Monad m => HasCfgKey StateRefOpt (Maybe String) m where instance Monad m => HasCfgKey StateRefOpt (Maybe String) m where
key = "state-ref" key = "state-ref"
class ToBalance e tx where class ToBalance s tx where
toBalance :: tx -> [(Account e, Amount)] toBalance :: tx -> [(Account s, Amount)]
tracePrefix :: SetLoggerEntry tracePrefix :: SetLoggerEntry
tracePrefix = toStderr . logPrefix "[trace] " tracePrefix = toStderr . logPrefix "[trace] "
@ -153,7 +153,7 @@ data MyEnv =
, myChan :: RefChanId UNIX , myChan :: RefChanId UNIX
, myRef :: MyRefKey , myRef :: MyRefKey
, mySto :: AnyStorage , mySto :: AnyStorage
, myCred :: PeerCredentials HBS2Basic , myCred :: PeerCredentials 'HBS2Basic
, myHttpPort :: Int , myHttpPort :: Int
, myFetch :: Cache HashRef () , myFetch :: Cache HashRef ()
} }
@ -211,8 +211,8 @@ instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (App m) where
tryLockForPeriod _ _ = pure True tryLockForPeriod _ _ = pure True
instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) where instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) where
type QBLFActor ConsensusQBLF = Actor L4Proto type QBLFActor ConsensusQBLF = Actor 'HBS2Basic
type QBLFTransaction ConsensusQBLF = QBLFDemoToken L4Proto type QBLFTransaction ConsensusQBLF = QBLFDemoToken 'HBS2Basic
type QBLFState ConsensusQBLF = DAppState type QBLFState ConsensusQBLF = DAppState
qblfMoveForward _ s1 = do qblfMoveForward _ s1 = do
@ -247,7 +247,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
-- пробуем разослать бандлы с транзакциями -- пробуем разослать бандлы с транзакциями
runMaybeT do runMaybeT do
ref <- MaybeT $ createBundle sto (fmap HashRef hashes) 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) r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r))) 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 sk = view peerSignSk creds
let pk = view peerSignPk creds let pk = view peerSignPk creds
nonce <- randomIO @Word64 <&> serialise <&> LBS.toStrict 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 let notify = Notify @UNIX chan box
request self notify request self notify
@ -327,17 +327,17 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t) 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 case tx of
Emit box -> do 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 ) guard ( chan == pk )
debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
pure ([(t,e)], mempty) pure ([(t,e)], mempty)
(Move box) -> do (Move box) -> do
(_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx 'HBS2Basic) box
guard (qty > 0) guard (qty > 0)
debug $ "MOVE TRANSACTION" <+> pretty t debug $ "MOVE TRANSACTION" <+> pretty t
@ -352,7 +352,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
bal0 <- balances (fromDAppState s0) bal0 <- balances (fromDAppState s0)
-- баланс с учётом новых emit -- баланс с учётом новых emit
let balE = foldMap (toBalance @L4Proto . snd) emits let balE = foldMap (toBalance @'HBS2Basic. snd) emits
& HashMap.fromListWith (+) & HashMap.fromListWith (+)
& HashMap.unionWith (+) bal0 & HashMap.unionWith (+) bal0
@ -391,12 +391,12 @@ balances :: forall e s m . ( e ~ L4Proto
, HasStorage m , HasStorage m
-- , FromStringMaybe (PubKey 'Sign s) -- , FromStringMaybe (PubKey 'Sign s)
, s ~ Encryption e , s ~ Encryption e
, ToBalance L4Proto (EmitTx L4Proto) , ToBalance s (EmitTx s)
, ToBalance L4Proto (MoveTx L4Proto) , ToBalance s (MoveTx s)
, Pretty (AsBase58 (PubKey 'Sign s)) , Pretty (AsBase58 (PubKey 'Sign s))
) )
=> HashRef => HashRef
-> m (HashMap (Account e) Amount) -> m (HashMap (Account s) Amount)
balances root = do balances root = do
sto <- getStorage sto <- getStorage
@ -406,7 +406,7 @@ balances root = do
cached <- runMaybeT do cached <- runMaybeT do
rval <- MaybeT $ liftIO $ getRef sto pk rval <- MaybeT $ liftIO $ getRef sto pk
val <- MaybeT $ liftIO $ getBlock sto rval 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) & either (const $ pure Nothing) (pure . Just)
case cached of case cached of
@ -417,16 +417,16 @@ balances root = do
r <- forM txs $ \h -> runMaybeT do r <- forM txs $ \h -> runMaybeT do
blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h) 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 case tx of
Emit box -> do Emit box -> do
(_, emit) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box (_, emit) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx s) box
pure $ toBalance @e emit pure $ toBalance @s emit
Move box -> do Move box -> do
(_, move) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box (_, move) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx s) box
pure $ toBalance @e move pure $ toBalance @s move
let val = catMaybes r & mconcat & HashMap.fromListWith (+) let val = catMaybes r & mconcat & HashMap.fromListWith (+)
@ -450,8 +450,8 @@ balances root = do
-- -> [(tx, b)] -- -> [(tx, b)]
-- -> [(tx, b)] -- -> [(tx, b)]
updBalances :: forall e a tx . (ForRefChans e, ToBalance e tx) updBalances :: forall e s a tx . (ForRefChans e, ToBalance s tx, s ~ Encryption e)
=> HashMap (Account e) Amount => HashMap (Account s) Amount
-> [(a, tx)] -> [(a, tx)]
-> [(a, tx)] -> [(a, tx)]
@ -467,7 +467,7 @@ updBalances = go
go bal rest go bal rest
where 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 good = HashMap.filter (<0) nb & HashMap.null
@ -515,7 +515,7 @@ runMe conf = withLogging $ flip runReaderT conf do
) `orDie` "state-ref not set" ) `orDie` "state-ref not set"
sc <- liftIO $ BS.readFile kr 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" 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" 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 let actors = view refChanHeadAuthors headBlk
& HashSet.toList & HashSet.toList
& fmap (Actor @L4Proto) & fmap Actor
runApp myEnv do runApp myEnv do
@ -590,7 +590,7 @@ runMe conf = withLogging $ flip runReaderT conf do
debug $ "GOT TX" <+> pretty hBin 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 tx <- case tok of
(Emit box) -> do (Emit box) -> do
@ -649,7 +649,7 @@ runMe conf = withLogging $ flip runReaderT conf do
let coco = hashObject @HbSync $ serialise msg let coco = hashObject @HbSync $ serialise msg
void $ runMaybeT do void $ runMaybeT do
(_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 @ByteString @UNIX msg (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 msg
qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped) qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
& either (const Nothing) Just & either (const Nothing) Just
@ -729,11 +729,11 @@ main = join . customExecParser (prefs showHelpOnError) $
dest <- strArgument ( metavar "ADDRESS" ) dest <- strArgument ( metavar "ADDRESS" )
pure $ const $ silently do pure $ const $ silently do
sc <- BS.readFile kr 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 pk = view peerSignPk creds
let sk = view peerSignSk creds let sk = view peerSignSk creds
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address" 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 LBS.putStr $ serialise tx
pGenMove = do pGenMove = do
@ -742,29 +742,29 @@ main = join . customExecParser (prefs showHelpOnError) $
dest <- strArgument ( metavar "ADDRESS" ) dest <- strArgument ( metavar "ADDRESS" )
pure $ const $ silently do pure $ const $ silently do
sc <- BS.readFile kr 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 pk = view peerSignPk creds
let sk = view peerSignSk creds let sk = view peerSignSk creds
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address" 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 LBS.putStr $ serialise tx
pCheckTx = do pCheckTx = do
kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" ) kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" )
pure $ const do pure $ const do
sc <- BS.readFile kr 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 pk = view peerSignPk creds
let sk = view peerSignSk creds let sk = view peerSignSk creds
tx <- LBS.getContents <&> deserialise @(QBLFDemoToken L4Proto) tx <- LBS.getContents <&> deserialise @(QBLFDemoToken 'HBS2Basic)
case tx of case tx of
Emit box -> do 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 Move box -> do
void $ pure (unboxSignedBox0 @(MoveTx L4Proto) @L4Proto box) `orDie` "bad move tx" void $ pure (unboxSignedBox0 box) `orDie` "bad move tx"
pure () pure ()

90
examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs
View File

@ -1,4 +1,6 @@
{-# Language UndecidableInstances #-} {-# Language UndecidableInstances #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language TypeOperators #-}
module Demo.QBLF.Transactions where module Demo.QBLF.Transactions where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
@ -16,17 +18,17 @@ import Data.ByteString.Lazy (ByteString)
import Data.Word (Word64) import Data.Word (Word64)
import System.Random import System.Random
newtype Actor e = newtype Actor s =
Actor { fromActor :: PubKey 'Sign (Encryption e) } Actor { fromActor :: PubKey 'Sign s }
deriving stock (Generic) deriving stock (Generic)
deriving stock instance Eq (PubKey 'Sign (Encryption e)) => Eq (Actor e) deriving stock instance Eq (PubKey 'Sign s) => Eq (Actor s)
deriving newtype instance Hashable (PubKey 'Sign (Encryption e)) => Hashable (Actor e) 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) pretty (Actor a) = pretty (AsBase58 a)
type Account e = PubKey 'Sign (Encryption e) type Account s = PubKey 'Sign s
newtype Amount = Amount Integer newtype Amount = Amount Integer
deriving stock (Eq,Show,Ord,Data,Generic) deriving stock (Eq,Show,Ord,Data,Generic)
@ -39,48 +41,48 @@ newtype DAppState = DAppState { fromDAppState :: HashRef }
instance Hashed HbSync DAppState where instance Hashed HbSync DAppState where
hashObject (DAppState (HashRef h)) = h hashObject (DAppState (HashRef h)) = h
data EmitTx e = EmitTx (Account e) Amount Word64 data EmitTx s = EmitTx (Account s) Amount Word64
deriving stock (Generic) 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) deriving stock (Generic)
data QBLFDemoToken e = data QBLFDemoToken s =
Emit (SignedBox (EmitTx e) e) -- proof: owner's key Emit (SignedBox (EmitTx s) s) -- proof: owner's key
| Move (SignedBox (MoveTx e) e) -- proof: wallet's key | Move (SignedBox (MoveTx s) s) -- proof: wallet's key
deriving stock (Generic) deriving stock (Generic)
instance ForRefChans e => Serialise (Actor e) instance ForQBLFDemoToken s => Serialise (Actor s)
instance Serialise DAppState instance Serialise DAppState
instance Serialise Amount 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)) type ForQBLFDemoToken s = ( Eq (PubKey 'Sign s)
, Eq (Signature (Encryption e)) , Eq (Signature s)
, Pretty (AsBase58 (PubKey 'Sign (Encryption e))) , Pretty (AsBase58 (PubKey 'Sign s))
, ForSignedBox e , ForSignedBox s
, FromStringMaybe (PubKey 'Sign (Encryption e)) , FromStringMaybe (PubKey 'Sign s)
, Serialise (PubKey 'Sign (Encryption e)) , Serialise (PubKey 'Sign s)
, Serialise (Signature (Encryption e)) , Serialise (Signature s)
, Hashable (PubKey 'Sign (Encryption e)) , 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 hashWithSalt salt = \case
Emit box -> hashWithSalt salt box Emit box -> hashWithSalt salt box
Move box -> hashWithSalt salt box Move box -> hashWithSalt salt box
newtype QBLFDemoTran e = newtype QBLFDemoTran e =
QBLFDemoTran (SignedBox (QBLFDemoToken e) e) QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e))
deriving stock Generic deriving stock Generic
instance ForRefChans e => Serialise (QBLFDemoTran e) instance ForRefChans e => Serialise (QBLFDemoTran e)
@ -93,39 +95,43 @@ deriving newtype instance
(Eq (Signature (Encryption e)), ForRefChans e) (Eq (Signature (Encryption e)), ForRefChans e)
=> Hashable (QBLFDemoTran 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 ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
type instance Encoded UNIX = ByteString type instance Encoded UNIX = ByteString
decode = either (const Nothing) Just . deserialiseOrFail decode = either (const Nothing) Just . deserialiseOrFail
encode = serialise encode = serialise
makeEmitTx :: forall e m . ( MonadIO m makeEmitTx :: forall s e m . ( MonadIO m
, ForRefChans e , ForRefChans e
, ForQBLFDemoToken s
, Signatures (Encryption e) , Signatures (Encryption e)
, s ~ Encryption e
) )
=> PubKey 'Sign (Encryption e) => PubKey 'Sign s
-> PrivKey 'Sign (Encryption e) -> PrivKey 'Sign s
-> Account e -> Account s
-> Amount -> Amount
-> m (QBLFDemoToken e) -> m (QBLFDemoToken s)
makeEmitTx pk sk acc amount = do makeEmitTx pk sk acc amount = do
nonce <- randomIO nonce <- randomIO
let box = makeSignedBox @e pk sk (EmitTx @e acc amount nonce) let box = makeSignedBox @s pk sk (EmitTx acc amount nonce)
pure (Emit @e box) pure (Emit @s box)
makeMoveTx :: forall e m . ( MonadIO m makeMoveTx :: forall s e m . ( MonadIO m
, ForQBLFDemoToken s
, ForRefChans e , ForRefChans e
, Signatures (Encryption e) , Signatures s
, s ~ Encryption e
) )
=> PubKey 'Sign (Encryption e) -- from pk => PubKey 'Sign s -- from pk
-> PrivKey 'Sign (Encryption e) -- from sk -> PrivKey 'Sign s -- from sk
-> Account e -> Account s
-> Amount -- amount -> Amount -- amount
-> m (QBLFDemoToken e) -> m (QBLFDemoToken s)
makeMoveTx pk sk acc amount = do makeMoveTx pk sk acc amount = do
nonce <- randomIO nonce <- randomIO
let box = makeSignedBox @e pk sk (MoveTx @e pk acc amount nonce) let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce)
pure (Move @e box) pure (Move @s box)

14
hbs2-core/lib/HBS2/Data/Bundle.hs
View File

@ -26,8 +26,8 @@ import Streaming()
{- HLINT ignore "Use newtype instead of data" -} {- HLINT ignore "Use newtype instead of data" -}
data BundleRefValue e = data BundleRefValue s =
BundleRefValue (SignedBox BundleRef e) BundleRefValue (SignedBox BundleRef s)
deriving stock (Generic) deriving stock (Generic)
instance ForSignedBox e => Serialise (BundleRefValue e) instance ForSignedBox e => Serialise (BundleRefValue e)
@ -39,13 +39,13 @@ data BundleRef =
instance Serialise BundleRef instance Serialise BundleRef
makeBundleRefValue :: forall e . (ForSignedBox e, Signatures (Encryption e)) makeBundleRefValue :: forall s . (ForSignedBox s, Signatures s)
=> PubKey 'Sign (Encryption e) => PubKey 'Sign s
-> PrivKey 'Sign (Encryption e) -> PrivKey 'Sign s
-> BundleRef -> 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
-- у нас может быть много способов хранить данные: -- у нас может быть много способов хранить данные:
-- сжимать целиком (эффективно, но медленно) -- сжимать целиком (эффективно, но медленно)

4
hbs2-core/lib/HBS2/Data/KeyRing.hs
View File

@ -43,7 +43,7 @@ findFilesBy fp = liftIO do
findKeyRing :: forall s m . ( MonadUnliftIO m findKeyRing :: forall s m . ( MonadUnliftIO m
, SerialisedCredentials s , SerialisedCredentials s
, ForHBS2Basic s , For'HBS2Basic s
) )
=> [FilePattern] => [FilePattern]
-> PubKey 'Sign s -> PubKey 'Sign s
@ -68,7 +68,7 @@ findKeyRing fp kr = do
findKeyRingEntries :: forall s m . ( MonadUnliftIO m findKeyRingEntries :: forall s m . ( MonadUnliftIO m
, SerialisedCredentials s , SerialisedCredentials s
, Hashable (PubKey 'Encrypt s) , Hashable (PubKey 'Encrypt s)
-- , ForHBS2Basic s -- , For'HBS2Basic s
) )
=> [FilePattern] => [FilePattern]
-> [PubKey 'Encrypt s] -> [PubKey 'Encrypt s]

58
hbs2-core/lib/HBS2/Data/Types/SignedBox.hs
View File

@ -11,62 +11,62 @@ import Data.Hashable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Function
import Control.Monad.Identity import Control.Monad.Identity
data SignedBox p e = data SignedBox p s =
SignedBox (PubKey 'Sign (Encryption e)) ByteString (Signature (Encryption e)) SignedBox (PubKey 'Sign s) ByteString (Signature s)
deriving stock (Generic) deriving stock (Generic)
deriving stock instance deriving stock instance
( Eq (PubKey 'Sign (Encryption e)) ( Eq (PubKey 'Sign s)
, Eq (Signature (Encryption e)) , Eq (Signature s)
) => Eq (SignedBox p e) ) => Eq (SignedBox p s)
instance ( Eq (PubKey 'Sign (Encryption e)) instance ( Eq (PubKey 'Sign s)
, Eq (Signature (Encryption e)) , Eq (Signature s)
, Serialise (SignedBox p e) , Serialise (SignedBox p s)
) => Hashable (SignedBox p e) where ) => Hashable (SignedBox p s) where
hashWithSalt salt box = hashWithSalt salt (serialise box) hashWithSalt salt box = hashWithSalt salt (serialise box)
type ForSignedBox e = ( Serialise ( PubKey 'Sign (Encryption e)) type ForSignedBox s = ( Serialise ( PubKey 'Sign s)
, FromStringMaybe (PubKey 'Sign (Encryption e)) , FromStringMaybe (PubKey 'Sign s)
, Serialise (Signature (Encryption e)) , Serialise (Signature s)
, Signatures (Encryption e) , Signatures s
, Hashable (PubKey 'Sign (Encryption e)) , 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)) makeSignedBox :: forall s p . (Serialise p, ForSignedBox s, Signatures s)
=> PubKey 'Sign (Encryption e) => PubKey 'Sign s
-> PrivKey 'Sign (Encryption e) -> PrivKey 'Sign s
-> p -> 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 where
bs = LBS.toStrict (serialise msg) 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)) unboxSignedBox0 :: forall p s . (Serialise p, ForSignedBox s, Signatures s)
=> SignedBox p e => SignedBox p s
-> Maybe (PubKey 'Sign (Encryption e), p) -> Maybe (PubKey 'Sign s, p)
unboxSignedBox0 (SignedBox pk bs sign) = runIdentity $ runMaybeT do 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 p <- MaybeT $ pure $ deserialiseOrFail @p (LBS.fromStrict bs) & either (const Nothing) Just
pure (pk, p) 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 => LBS.ByteString
-> Maybe (PubKey 'Sign (Encryption e), p) -> Maybe (PubKey 'Sign s, p)
unboxSignedBox bs = runIdentity $ runMaybeT do 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 & either (pure Nothing) Just
MaybeT $ pure $ unboxSignedBox0 box MaybeT $ pure $ unboxSignedBox0 box

49
hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
View File

@ -29,13 +29,9 @@ import Data.List qualified as List
import Lens.Micro.Platform import Lens.Micro.Platform
import Data.Kind 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 instance Signatures 'HBS2Basic where
type Signature HBS2Basic = Sign.Signature type Signature 'HBS2Basic = Sign.Signature
makeSign = Sign.signDetached makeSign = Sign.signDetached
verifySign = Sign.signVerifyDetached verifySign = Sign.signVerifyDetached
@ -68,10 +64,10 @@ class AsymmPubKey e ~ PubKey 'Encrypt e => Asymm e where
class HasCredentials s m where class HasCredentials s m where
getCredentials :: m (PeerCredentials s) getCredentials :: m (PeerCredentials s)
data KeyringEntry e = data KeyringEntry s =
KeyringEntry KeyringEntry
{ _krPk :: PubKey 'Encrypt e { _krPk :: PubKey 'Encrypt s
, _krSk :: PrivKey 'Encrypt e , _krSk :: PrivKey 'Encrypt s
, _krDesc :: Maybe Text , _krDesc :: Maybe Text
} }
deriving stock (Generic) deriving stock (Generic)
@ -94,24 +90,25 @@ data PeerCredentials s =
makeLenses 'KeyringEntry makeLenses 'KeyringEntry
makeLenses 'PeerCredentials makeLenses 'PeerCredentials
type ForHBS2Basic s = ( Signatures s type For'HBS2Basic s = ( Signatures s
, PrivKey 'Sign s ~ Sign.SecretKey , PrivKey 'Sign s ~ Sign.SecretKey
, PubKey 'Sign s ~ Sign.PublicKey , PubKey 'Sign s ~ Sign.PublicKey
, Eq (PubKey 'Encrypt HBS2Basic) , Eq (PubKey 'Encrypt 'HBS2Basic)
, IsEncoding (PubKey 'Encrypt s) , IsEncoding (PubKey 'Encrypt s)
, Eq (PubKey 'Encrypt HBS2Basic) , Eq (PubKey 'Encrypt 'HBS2Basic)
, s ~ HBS2Basic , s ~ 'HBS2Basic
) )
type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e) type SerialisedCredentials ( s :: CryptoScheme ) =
, Serialise (PubKey 'Sign e) ( Serialise (PrivKey 'Sign s)
, Serialise (PubKey 'Encrypt e) , Serialise (PubKey 'Sign s)
, Serialise (PrivKey 'Encrypt e) , 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 newtype AsCredFile a = AsCredFile a
@ -150,7 +147,7 @@ addKeyPair txt cred = do
pure $ cred & over peerKeyring (List.nub . (<> [kp])) pure $ cred & over peerKeyring (List.nub . (<> [kp]))
delKeyPair :: forall e m . ( MonadIO m delKeyPair :: forall e m . ( MonadIO m
, ForHBS2Basic e , For'HBS2Basic e
) )
=> AsBase58 String -> PeerCredentials e -> m (PeerCredentials e) => AsBase58 String -> PeerCredentials e -> m (PeerCredentials e)
delKeyPair (AsBase58 pks) cred = do delKeyPair (AsBase58 pks) cred = do
@ -160,7 +157,7 @@ delKeyPair (AsBase58 pks) cred = do
pure $ cred & set peerKeyring rest pure $ cred & set peerKeyring rest
parseCredentials :: forall s . ( -- ForHBS2Basic s parseCredentials :: forall s . ( -- For'HBS2Basic s
SerialisedCredentials s SerialisedCredentials s
) )
=> AsCredFile ByteString -> Maybe (PeerCredentials 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))) pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke)))
instance Asymm HBS2Basic where instance Asymm 'HBS2Basic where
type AsymmKeypair HBS2Basic = Encrypt.Keypair type AsymmKeypair 'HBS2Basic = Encrypt.Keypair
type AsymmPrivKey HBS2Basic = Encrypt.SecretKey type AsymmPrivKey 'HBS2Basic = Encrypt.SecretKey
type AsymmPubKey HBS2Basic = Encrypt.PublicKey type AsymmPubKey 'HBS2Basic = Encrypt.PublicKey
type CommonSecret HBS2Basic = Encrypt.CombinedKey type CommonSecret 'HBS2Basic = Encrypt.CombinedKey
asymmNewKeypair = liftIO Encrypt.newKeypair asymmNewKeypair = liftIO Encrypt.newKeypair
privKeyFromKeypair = Encrypt.secretKey privKeyFromKeypair = Encrypt.secretKey
pubKeyFromKeypair = Encrypt.publicKey pubKeyFromKeypair = Encrypt.publicKey

52
hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs
View File

@ -26,9 +26,9 @@ import Lens.Micro.Platform
-- Contains an encryption public key, optional additional information, -- Contains an encryption public key, optional additional information,
-- and a possible reference to an additional information block. -- and a possible reference to an additional information block.
data SigilData e = data SigilData s =
SigilData SigilData
{ sigilDataEncKey :: PubKey 'Encrypt (Encryption e) { sigilDataEncKey :: PubKey 'Encrypt s
, sigilDataInfo :: Maybe Text , sigilDataInfo :: Maybe Text
, sigilDataExt :: Maybe HashRef , sigilDataExt :: Maybe HashRef
} }
@ -40,34 +40,34 @@ data SigilData e =
-- Includes a signature public key and signed 'SigilData', -- Includes a signature public key and signed 'SigilData',
-- ensuring user authentication and verification. -- ensuring user authentication and verification.
data Sigil e = data Sigil s =
Sigil Sigil
{ sigilSignPk :: PubKey 'Sign (Encryption e) { sigilSignPk :: PubKey 'Sign s
, sigilData :: SignedBox (SigilData e) e , sigilData :: SignedBox (SigilData s) s
} }
deriving stock (Generic) deriving stock (Generic)
type ForSigil e = ( Serialise (PubKey 'Encrypt (Encryption e)) type ForSigil s = ( Serialise (PubKey 'Encrypt s)
, Serialise (PubKey 'Sign (Encryption e)) , Serialise (PubKey 'Sign s)
, Serialise (Signature (Encryption e)) , Serialise (Signature s)
, Signatures (Encryption e) , Signatures s
, Hashable (PubKey 'Sign (Encryption e)) , Hashable (PubKey 'Sign s)
, IsEncoding (PubKey 'Encrypt (Encryption e)) , IsEncoding (PubKey 'Encrypt s)
, Eq (PubKey 'Encrypt (Encryption e)) , Eq (PubKey 'Encrypt s)
, FromStringMaybe (PubKey 'Sign (Encryption e)) , FromStringMaybe (PubKey 'Sign s)
) )
type ForPrettySigil e = type ForPrettySigil s =
( IsEncoding (PubKey 'Encrypt (Encryption e)) ( IsEncoding (PubKey 'Encrypt s)
, Pretty (AsBase58 (PubKey 'Sign (Encryption e))) , Pretty (AsBase58 (PubKey 'Sign s))
) )
instance ForSigil e => Serialise (SigilData e) instance ForSigil s => Serialise (SigilData s)
instance ForSigil e => Serialise (Sigil e) 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) pretty s = vcat $ [ parens ("encrypt-pubkey" <+> dquotes epk)
] <> catMaybes [pinfo, pext] ] <> catMaybes [pinfo, pext]
where where
@ -75,7 +75,7 @@ instance ForPrettySigil e => Pretty (SigilData e) where
pinfo = sigilDataInfo s >>= \x -> pure $ parens ("info" <+> dquotes (pretty x)) pinfo = sigilDataInfo s >>= \x -> pure $ parens ("info" <+> dquotes (pretty x))
pext = sigilDataExt s >>= \x -> pure $ parens ("ext" <+> 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 pretty s = vcat
[ parens ("sign-pubkey" <+> psk) [ parens ("sign-pubkey" <+> psk)
] ]
@ -83,12 +83,12 @@ instance ForPrettySigil e => Pretty (Sigil e) where
psk = dquotes (pretty (AsBase58 (sigilSignPk s))) psk = dquotes (pretty (AsBase58 (sigilSignPk s)))
-- Nothing, если ключ отсутствует в Credentials -- Nothing, если ключ отсутствует в Credentials
makeSigilFromCredentials :: forall e . ForSigil e makeSigilFromCredentials :: forall s . ForSigil s
=> PeerCredentials (Encryption e) => PeerCredentials s
-> PubKey 'Encrypt (Encryption e) -> PubKey 'Encrypt s
-> Maybe Text -> Maybe Text
-> Maybe HashRef -> Maybe HashRef
-> Maybe (Sigil e) -> Maybe (Sigil s)
makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do 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 sd = SigilData ke i ha
let box = makeSignedBox @e ppk psk sd let box = makeSignedBox @s ppk psk sd
let sigil = Sigil let sigil = Sigil
{ sigilSignPk = view peerSignPk cred { sigilSignPk = view peerSignPk cred
@ -112,7 +112,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
pure sigil 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 pretty (AsBase58 s) = "# sigil file. public data" <> line <> sd
where where
sd = vcat $ fmap pretty sd = vcat $ fmap pretty

9
hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs
View File

@ -8,7 +8,6 @@ import HBS2.Base58
import HBS2.Data.Types import HBS2.Data.Types
import HBS2.Data.Types.EncryptedBox import HBS2.Data.Types.EncryptedBox
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Types
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import Codec.Serialise import Codec.Serialise
@ -21,7 +20,7 @@ import Data.ByteString.Char8 (ByteString)
import Data.List.Split (chunksOf) import Data.List.Split (chunksOf)
type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s) type ForAccessKey (s :: CryptoScheme) = ( Crypto.IsEncoding (PubKey 'Encrypt s)
, Serialise (PubKey 'Encrypt s) , Serialise (PubKey 'Encrypt s)
, Serialise (PubKey 'Sign s) , Serialise (PubKey 'Sign s)
, Serialise (PrivKey 'Sign s) , Serialise (PrivKey 'Sign s)
@ -30,11 +29,9 @@ type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s)
--- data family AccessKey ( s :: CryptoScheme )
data family AccessKey s newtype instance AccessKey (s :: CryptoScheme) =
newtype instance AccessKey s =
AccessKeyNaClAsymm AccessKeyNaClAsymm
{ permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))] { permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))]
} }

23
hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs
View File

@ -13,6 +13,7 @@ import HBS2.Base58
import HBS2.Data.Types.EncryptedBox import HBS2.Data.Types.EncryptedBox
import HBS2.Data.Types.SmallEncryptedBlock import HBS2.Data.Types.SmallEncryptedBlock
import HBS2.Data.Types.Refs import HBS2.Data.Types.Refs
import HBS2.Net.Auth.Schema
import HBS2.Hash import HBS2.Hash
import HBS2.Merkle import HBS2.Merkle
import HBS2.Data.Detect import HBS2.Data.Detect
@ -96,13 +97,16 @@ data instance ToEncrypt 'Symm s LBS.ByteString =
} }
deriving (Generic) deriving (Generic)
type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s) type ForGroupKeySymm (s :: CryptoScheme ) =
, PubKey 'Encrypt s ~ AK.PublicKey (
, PrivKey 'Encrypt s ~ AK.SecretKey -- Eq (PubKey 'Encrypt s)
, Serialise (PubKey 'Encrypt s) -- , PubKey 'Encrypt s
-- , PrivKey 'Encrypt s
Serialise (PubKey 'Encrypt s)
, Serialise GroupSecret , Serialise GroupSecret
, Serialise SK.Nonce , Serialise SK.Nonce
, FromStringMaybe (PubKey 'Encrypt s) , FromStringMaybe (PubKey 'Encrypt s)
, Hashable (PubKey 'Encrypt s)
) )
instance ForGroupKeySymm s => Serialise (GroupKey 'Symm 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 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 => Maybe GroupSecret
-> [PubKey 'Encrypt s] -> [PubKey 'Encrypt s]
-> m (GroupKey 'Symm s) -> m (GroupKey 'Symm s)
@ -155,7 +159,10 @@ generateGroupKey mbk pks = GroupKeySymm <$> create
box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
pure (pk, box) pure (pk, box)
lookupGroupKey :: ForGroupKeySymm s lookupGroupKey :: forall s . ( ForGroupKeySymm s
, PubKey 'Encrypt s ~ AK.PublicKey
, PrivKey 'Encrypt s ~ AK.SecretKey
)
=> PrivKey 'Encrypt s => PrivKey 'Encrypt s
-> PubKey 'Encrypt s -> PubKey 'Encrypt s
-> GroupKey 'Symm s -> GroupKey 'Symm s
@ -278,8 +285,8 @@ instance ( MonadIO m
, MonadError OperationError m , MonadError OperationError m
, h ~ HbSync , h ~ HbSync
, Storage s h ByteString m , Storage s h ByteString m
, sch ~ 'HBS2Basic
-- TODO: why? -- TODO: why?
, sch ~ HBS2Basic
) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
data instance TreeKey (ToDecrypt 'Symm sch ByteString) = data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
@ -389,6 +396,8 @@ decryptBlock :: forall t s sto h m . ( MonadIO m
, MonadError OperationError m , MonadError OperationError m
, Storage sto h ByteString m , Storage sto h ByteString m
, ForGroupKeySymm s , ForGroupKeySymm s
, PubKey 'Encrypt s ~ AK.PublicKey
, PrivKey 'Encrypt s ~ AK.SecretKey
, h ~ HbSync , h ~ HbSync
, Serialise t , Serialise t
) )

25
hbs2-core/lib/HBS2/Net/Auth/Schema.hs
View File

@ -5,7 +5,7 @@ module HBS2.Net.Auth.Schema
, module HBS2.Net.Proto.Types , module HBS2.Net.Proto.Types
) where ) where
import HBS2.Prelude import HBS2.Prelude.Plated
import HBS2.OrDie import HBS2.OrDie
import HBS2.Net.Proto.Types import HBS2.Net.Proto.Types
import HBS2.Hash import HBS2.Hash
@ -17,21 +17,36 @@ import Crypto.PubKey.Ed25519 qualified as Ed
import Crypto.KDF.HKDF qualified as HKDF import Crypto.KDF.HKDF qualified as HKDF
import Crypto.Saltine.Class qualified as Saltine import Crypto.Saltine.Class qualified as Saltine
import Crypto.Saltine.Class (IsEncoding(..)) 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 Codec.Serialise
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteArray ( convert) 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)) 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 derivedKey nonce sk = do
sk0 <- liftIO $ throwCryptoErrorIO (Ed.secretKey k0) sk0 <- liftIO $ throwCryptoErrorIO (Ed.secretKey k0)

19
hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs
View File

@ -76,10 +76,10 @@ mySipHash s = BA.sipHash (SipKey a b) s
-- --
data ByPassOpts e = data ByPassOpts s =
ByPassOpts ByPassOpts
{ byPassEnabled :: Bool { byPassEnabled :: Bool
, byPassKeyAllowed :: PubKey 'Sign (Encryption e) -> IO Bool , byPassKeyAllowed :: PubKey 'Sign s -> IO Bool
, byPassTimeRange :: Maybe (Int, Int) , byPassTimeRange :: Maybe (Int, Int)
} }
@ -101,7 +101,7 @@ instance Serialise ByPassStat
data ByPass e them = data ByPass e them =
ByPass ByPass
{ opts :: ByPassOpts e { opts :: ByPassOpts (Encryption e)
, self :: Peer e , self :: Peer e
, pks :: PubKey 'Sign (Encryption e) , pks :: PubKey 'Sign (Encryption e)
, sks :: PrivKey 'Sign (Encryption e) , sks :: PrivKey 'Sign (Encryption e)
@ -128,7 +128,7 @@ type ForByPass e = ( Hashable (Peer e)
, Serialise (PubKey 'Sign (Encryption e)) , Serialise (PubKey 'Sign (Encryption e))
, PrivKey 'Encrypt (Encryption e) ~ PKE.SecretKey , PrivKey 'Encrypt (Encryption e) ~ PKE.SecretKey
, PubKey 'Encrypt (Encryption e) ~ PKE.PublicKey , PubKey 'Encrypt (Encryption e) ~ PKE.PublicKey
, ForSignedBox e , ForSignedBox (Encryption e)
) )
@ -136,12 +136,12 @@ data HEYBox e =
HEYBox Int (PubKey 'Encrypt (Encryption e)) HEYBox Int (PubKey 'Encrypt (Encryption e))
deriving stock Generic deriving stock Generic
instance ForByPass e => Serialise (HEYBox e) instance ForByPass s => Serialise (HEYBox s)
data EncryptHandshake e = data EncryptHandshake e =
HEY HEY
{ heyNonceA :: NonceA { heyNonceA :: NonceA
, heyBox :: SignedBox (HEYBox e) e , heyBox :: SignedBox (HEYBox e) (Encryption e)
} }
deriving stock (Generic) deriving stock (Generic)
@ -210,7 +210,7 @@ newByPassMessaging :: forall e w m . ( ForByPass e
, MonadIO m , MonadIO m
, Messaging w e ByteString , Messaging w e ByteString
) )
=> ByPassOpts e => ByPassOpts (Encryption e)
-> w -> w
-> Peer e -> Peer e
-> PubKey 'Sign (Encryption e) -> PubKey 'Sign (Encryption e)
@ -370,9 +370,10 @@ makeKey a b = runIdentity do
pure $ (f0 `shiftL` 16) .|. f1 pure $ (f0 `shiftL` 16) .|. f1
sendHey :: forall e w m . ( ForByPass e sendHey :: forall e w m s . ( ForByPass e
, Messaging w e ByteString , Messaging w e ByteString
, MonadIO m , MonadIO m
, s ~ Encryption e
) )
=> ByPass e w => ByPass e w
-> Peer e -> Peer e
@ -387,7 +388,7 @@ sendHey bus whom = do
ts <- liftIO getPOSIXTime <&> round ts <- liftIO getPOSIXTime <&> round
let hbox = HEYBox @e ts (pke bus) 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 hey = HEY @e (nonceA bus) box
let msg = pref <> serialise hey let msg = pref <> serialise hey

19
hbs2-core/lib/HBS2/Net/Proto/Types.hs
View File

@ -9,7 +9,6 @@ module HBS2.Net.Proto.Types
) where ) where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import HBS2.Clock
import HBS2.Net.IP.Addr import HBS2.Net.IP.Addr
import Control.Applicative import Control.Applicative
@ -37,14 +36,19 @@ data CryptoAction = Sign | Encrypt
data GroupKeyScheme = Symm | Asymm data GroupKeyScheme = Symm | Asymm
deriving stock (Eq,Ord,Show,Data,Generic) deriving stock (Eq,Ord,Show,Data,Generic)
type family PubKey (a :: CryptoAction) e :: Type data CryptoScheme = HBS2Basic
type family PrivKey (a :: CryptoAction) e :: Type
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 type family KeyActionOf k :: CryptoAction
data family GroupKey (scheme :: GroupKeyScheme) s data family GroupKey (scheme :: GroupKeyScheme) (s :: CryptoScheme)
-- NOTE: throws-error -- NOTE: throws-error
class MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where 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 -- TODO: move-to-an-appropriate-place
newtype AsGroupKeyFile a = AsGroupKeyFile a 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 -- FIXME: move-to-a-crypto-definition-modules
@ -168,7 +172,6 @@ instance HasPeer L4Proto where
} }
deriving stock (Eq,Ord,Show,Generic) deriving stock (Eq,Ord,Show,Generic)
instance AddrPriority (Peer L4Proto) where instance AddrPriority (Peer L4Proto) where
addrPriority (PeerL4 _ sa) = addrPriority sa addrPriority (PeerL4 _ sa) = addrPriority sa

4
hbs2-core/test/TestDerivedKey.hs
View File

@ -15,13 +15,13 @@ import Data.Word
testDerivedKeys1 :: IO () testDerivedKeys1 :: IO ()
testDerivedKeys1 = do testDerivedKeys1 = do
cred <- newCredentials @HBS2Basic cred <- newCredentials @'HBS2Basic
let _ = view peerSignPk cred let _ = view peerSignPk cred
let sk = view peerSignSk cred let sk = view peerSignSk cred
let nonce = 0x123456780928934 :: Word64 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) let box = makeSignedBox @L4Proto pk1 sk1 (42 :: Word32)

8
hbs2-fixer/app/Main.hs
View File

@ -64,8 +64,8 @@ import System.Exit
type Config = [Syntax C] type Config = [Syntax C]
type RLWW = LWWRefKey HBS2Basic type RLWW = LWWRefKey 'HBS2Basic
type RRefLog = RefLogKey HBS2Basic type RRefLog = RefLogKey 'HBS2Basic
newtype Watcher = newtype Watcher =
Watcher [Syntax C] Watcher [Syntax C]
@ -81,7 +81,7 @@ instance Pretty Ref where
pretty (RefLWW r) = parens $ "lwwref" <+> dquotes (pretty r) pretty (RefLWW r) = parens $ "lwwref" <+> dquotes (pretty r)
newtype AnyPolledRef = newtype AnyPolledRef =
AnyPolledRef (PubKey 'Sign HBS2Basic) AnyPolledRef (PubKey 'Sign 'HBS2Basic)
deriving (Eq,Generic) deriving (Eq,Generic)
instance Hashable AnyPolledRef instance Hashable AnyPolledRef
@ -91,7 +91,7 @@ deriving newtype instance Hashable Id
instance Pretty AnyPolledRef where instance Pretty AnyPolledRef where
pretty (AnyPolledRef r) = pretty (AsBase58 r) 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 instance FromStringMaybe AnyPolledRef where
fromStringMay = fmap AnyPolledRef . fromStringMay fromStringMay = fmap AnyPolledRef . fromStringMay

4
hbs2-git/git-hbs2-subscribe/Main.hs
View File

@ -28,7 +28,7 @@ main = do
where where
pLww :: ReadM (LWWRefKey HBS2Basic) pLww :: ReadM (LWWRefKey 'HBS2Basic)
pLww = maybeReader fromStringMay 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 instance Monad m => HasAPI RefLogAPI UNIX (MyApp m) where
getAPI = asks _refLogAPI 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 subscribe soname' ref = do
soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc" soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc"

2
hbs2-git/git-hbs2/Main.hs
View File

@ -47,7 +47,7 @@ pRefLogId :: ReadM RefLogId
pRefLogId = maybeReader (fromStringMay @RefLogId) pRefLogId = maybeReader (fromStringMay @RefLogId)
pLwwKey :: ReadM (LWWRefKey HBS2Basic) pLwwKey :: ReadM (LWWRefKey 'HBS2Basic)
pLwwKey = maybeReader fromStringMay pLwwKey = maybeReader fromStringMay
pHashRef :: ReadM HashRef pHashRef :: ReadM HashRef

4
hbs2-git/git-remote-hbs2/Main.hs
View File

@ -48,7 +48,7 @@ sendLine = liftIO . IO.putStrLn
die :: (MonadIO m, Pretty a) => a -> m b die :: (MonadIO m, Pretty a) => a -> m b
die s = liftIO $ Exit.die (show $ pretty s) 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) parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
where where
p = do p = do
@ -56,7 +56,7 @@ parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
Atto.takeWhile1 (`elem` getAlphabet) Atto.takeWhile1 (`elem` getAlphabet)
<&> BS8.unpack <&> BS8.unpack
<&> fromStringMay @(LWWRefKey HBS2Basic) <&> fromStringMay @(LWWRefKey 'HBS2Basic)
>>= maybe (fail "invalid reflog key") pure >>= maybe (fail "invalid reflog key") pure
parsePush :: String -> Maybe (Maybe GitRef, GitRef) parsePush :: String -> Maybe (Maybe GitRef, GitRef)

2
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs
View File

@ -46,7 +46,7 @@ data GitEnv =
, _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX , _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX
, _db :: DBPipeEnv , _db :: DBPipeEnv
, _progress :: AnyProgress , _progress :: AnyProgress
, _keyringCache :: TVar (HashMap HashRef [KeyringEntry HBS2Basic]) , _keyringCache :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic])
} }

4
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs
View File

@ -153,7 +153,7 @@ export :: ( GitPerks m
, GroupKeyOperations m , GroupKeyOperations m
, HasAPI PeerAPI UNIX m , HasAPI PeerAPI UNIX m
) )
=> LWWRefKey HBS2Basic => LWWRefKey 'HBS2Basic
-> [(GitRef,Maybe GitHash)] -> [(GitRef,Maybe GitHash)]
-> m () -> m ()
export key refs = do export key refs = do
@ -177,7 +177,7 @@ export key refs = do
>>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0)) >>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0))
pure ( view peerSignSk creds, view peerSignPk creds ) pure ( view peerSignSk creds, view peerSignPk creds )
(puk,sk) <- derivedKey @HBS2Basic @'Sign lwwRefSeed sk0 (puk,sk) <- derivedKey @'HBS2Basic @'Sign lwwRefSeed sk0
subscribeRefLog puk subscribeRefLog puk

4
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs
View File

@ -66,7 +66,7 @@ merelySubscribeRepo :: forall e s m . ( GitPerks m
, e ~ L4Proto , e ~ L4Proto
, s ~ Encryption e , s ~ Encryption e
) )
=> LWWRefKey HBS2Basic => LWWRefKey 'HBS2Basic
-> m (Maybe (PubKey 'Sign s)) -> m (Maybe (PubKey 'Sign s))
merelySubscribeRepo lwwKey = do merelySubscribeRepo lwwKey = do
@ -108,7 +108,7 @@ importRepoWait :: ( GitPerks m
, HasAPI LWWRefAPI UNIX m , HasAPI LWWRefAPI UNIX m
, HasAPI RefLogAPI UNIX m , HasAPI RefLogAPI UNIX m
) )
=> LWWRefKey HBS2Basic => LWWRefKey 'HBS2Basic
-> m () -> m ()
importRepoWait lwwKey = do importRepoWait lwwKey = do

2
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs
View File

@ -22,7 +22,7 @@ class HasProgress a where
data ProgressEvent = data ProgressEvent =
ImportIdle ImportIdle
| ImportWaitLWW Int (LWWRefKey HBS2Basic) | ImportWaitLWW Int (LWWRefKey 'HBS2Basic)
| ImportRefLogStart RefLogId | ImportRefLogStart RefLogId
| ImportRefLogDone RefLogId (Maybe HashRef) | ImportRefLogDone RefLogId (Maybe HashRef)
| ImportWaitTx HashRef | ImportWaitTx HashRef

4
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs
View File

@ -27,12 +27,12 @@ subscribeRefLog puk = do
api <- getAPI @PeerAPI @UNIX api <- getAPI @PeerAPI @UNIX
void $ callService @RpcPollAdd api (puk, "reflog", 13) 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 subscribeLWWRef puk = do
api <- getAPI @PeerAPI @UNIX api <- getAPI @PeerAPI @UNIX
void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17) 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 fetchLWWRef key = do
api <- getAPI @LWWRefAPI @UNIX api <- getAPI @LWWRefAPI @UNIX
void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key) void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)

10
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs
View File

@ -30,7 +30,7 @@ instance Pretty (AsBase58 a) => ToField (Base58Field a) where
instance IsString a => FromField (Base58Field a) where instance IsString a => FromField (Base58Field a) where
fromField = fmap (Base58Field . fromString) . fromField @String fromField = fmap (Base58Field . fromString) . fromField @String
instance FromField (RefLogKey HBS2Basic) where instance FromField (RefLogKey 'HBS2Basic) where
fromField = fmap fromString . fromField @String fromField = fmap fromString . fromField @String
instance ToField HashRef where instance ToField HashRef where
@ -51,7 +51,7 @@ instance FromField GitRef where
instance FromField GitHash where instance FromField GitHash where
fromField = fmap fromString . fromField @String fromField = fmap fromString . fromField @String
instance FromField (LWWRefKey HBS2Basic) where instance FromField (LWWRefKey 'HBS2Basic) where
fromField = fmap fromString . fromField @String fromField = fmap fromString . fromField @String
createStateDir :: (GitPerks m, MonadReader GitEnv m) => m () createStateDir :: (GitPerks m, MonadReader GitEnv m) => m ()
@ -367,16 +367,16 @@ limit 1
|] (Only (Base58Field reflog)) <&> listToMaybe |] (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 insertLww lww snum reflog = do
insert [qc| insert [qc|
INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?) INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?)
ON CONFLICT (hash,seq,reflog) DO NOTHING ON CONFLICT (hash,seq,reflog) DO NOTHING
|] (Base58Field lww, snum, Base58Field reflog) |] (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 selectAllLww = do
select_ [qc| select_ [qc|
SELECT hash, seq, reflog FROM lww SELECT hash, seq, reflog FROM lww
|] <&> fmap (over _3 (fromRefLogKey @HBS2Basic)) |] <&> fmap (over _3 (fromRefLogKey @'HBS2Basic))

4
hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs
View File

@ -7,7 +7,7 @@ import HBS2.Storage.Operations.ByteString
import Data.ByteString.Lazy qualified as LBS 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 :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m GK0
readGK0 sto h = do readGK0 sto h = do
@ -22,5 +22,5 @@ loadGK0FromFile fp = runMaybeT do
content <- liftIO (try @_ @IOError (LBS.readFile fp)) content <- liftIO (try @_ @IOError (LBS.readFile fp))
>>= toMPlus >>= toMPlus
toMPlus $ parseGroupKey @HBS2Basic (AsGroupKeyFile content) toMPlus $ parseGroupKey @'HBS2Basic (AsGroupKeyFile content)

35
hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs
View File

@ -3,7 +3,6 @@
module HBS2.Git.Data.LWWBlock module HBS2.Git.Data.LWWBlock
( module HBS2.Git.Data.LWWBlock ( module HBS2.Git.Data.LWWBlock
, module HBS2.Peer.Proto.LWWRef , module HBS2.Peer.Proto.LWWRef
, HBS2Basic
) where ) where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
@ -42,19 +41,19 @@ import Control.Monad.Trans.Maybe
-- (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX]) -- (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX])
-- --
data LWWBlockData e = data LWWBlockData s =
LWWBlockData LWWBlockData
{ lwwRefSeed :: Word64 { lwwRefSeed :: Word64
, lwwRefLogPubKey :: PubKey 'Sign (Encryption e) , lwwRefLogPubKey :: PubKey 'Sign s
} }
deriving stock Generic deriving stock Generic
data LWWBlock e = data LWWBlock s =
LWWBlock1 { lwwBlockData :: LWWBlockData e } LWWBlock1 { lwwBlockData :: LWWBlockData s }
deriving stock Generic deriving stock Generic
instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e) instance Serialise (PubKey 'Sign s) => Serialise (LWWBlockData s)
instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e) instance Serialise (PubKey 'Sign s) => Serialise (LWWBlock s)
data LWWBlockOpError = data LWWBlockOpError =
@ -67,38 +66,34 @@ instance Exception LWWBlockOpError
{- HLINT ignore "Functor law" -} {- HLINT ignore "Functor law" -}
readLWWBlock :: forall e s m . ( MonadIO m readLWWBlock :: forall s m . ( MonadIO m
, Signatures s , Signatures s
, s ~ Encryption e , ForLWWRefProto s
, ForLWWRefProto e
, IsRefPubKey s , IsRefPubKey s
, e ~ L4Proto
) )
=> AnyStorage => AnyStorage
-> LWWRefKey s -> LWWRefKey s
-> m (Maybe (LWWRef e, LWWBlockData e)) -> m (Maybe (LWWRef s, LWWBlockData s))
readLWWBlock sto k = runMaybeT do readLWWBlock sto k = runMaybeT do
w@LWWRef{..} <- runExceptT (readLWWRef @e sto k) w@LWWRef{..} <- runExceptT (readLWWRef @s sto k)
>>= toMPlus >>= toMPlus
>>= toMPlus >>= toMPlus
getBlock sto (fromHashRef lwwValue) getBlock sto (fromHashRef lwwValue)
>>= toMPlus >>= toMPlus
<&> deserialiseOrFail @(LWWBlock e) <&> deserialiseOrFail @(LWWBlock s)
>>= toMPlus >>= toMPlus
<&> lwwBlockData <&> lwwBlockData
<&> (w,) <&> (w,)
initLWWRef :: forall e s m . ( MonadIO m initLWWRef :: forall s m . ( MonadIO m
, MonadError LWWBlockOpError m , MonadError LWWBlockOpError m
, IsRefPubKey s , IsRefPubKey s
, ForSignedBox e , ForSignedBox s
, HasDerivedKey s 'Sign Word64 m , HasDerivedKey s 'Sign Word64 m
, s ~ Encryption e
, Signatures s , Signatures s
, e ~ L4Proto
) )
=> AnyStorage => AnyStorage
-> Maybe Word64 -> Maybe Word64
@ -116,7 +111,7 @@ initLWWRef sto seed' findSk lwwKey = do
lww0 <- runMaybeT do lww0 <- runMaybeT do
getRef sto lwwKey >>= toMPlus getRef sto lwwKey >>= toMPlus
>>= getBlock sto >>= toMPlus >>= getBlock sto >>= toMPlus
<&> deserialiseOrFail @(SignedBox (LWWRef e) e) <&> deserialiseOrFail @(SignedBox (LWWRef s) s)
>>= toMPlus >>= toMPlus
<&> unboxSignedBox0 <&> unboxSignedBox0
>>= toMPlus >>= toMPlus
@ -124,7 +119,7 @@ initLWWRef sto seed' findSk lwwKey = do
(pk1, _) <- derivedKey @s @'Sign seed sk0 (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) hx <- putBlock sto (serialise newLwwData)
>>= orThrowError LWWBlockOpStorageError >>= orThrowError LWWBlockOpStorageError

2
hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs
View File

@ -2,6 +2,6 @@ module HBS2.Git.Data.RefLog where
import HBS2.Git.Client.Prelude import HBS2.Git.Client.Prelude
type RefLogId = PubKey 'Sign HBS2Basic type RefLogId = PubKey 'Sign 'HBS2Basic

10
hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs
View File

@ -69,7 +69,7 @@ instance Exception TxKeyringNotFound
class GroupKeyOperations m where class GroupKeyOperations m where
openGroupKey :: GK0 -> m (Maybe GroupSecret) openGroupKey :: GK0 -> m (Maybe GroupSecret)
loadKeyrings :: HashRef -> m [KeyringEntry HBS2Basic] loadKeyrings :: HashRef -> m [KeyringEntry 'HBS2Basic]
makeRepoHeadSimple :: MonadIO m makeRepoHeadSimple :: MonadIO m
=> Text => Text
@ -85,7 +85,7 @@ makeRepoHeadSimple name brief manifest gk refs = do
writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef
writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> 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 => AnyStorage
-> Bool -- ^ rewrite bundle merkle tree with new gk0 -> Bool -- ^ rewrite bundle merkle tree with new gk0
-> Rank -- ^ tx rank -> 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 makeTx sto rewrite r puk findSk rh prev lbss = do
let rfk = RefLogKey @HBS2Basic puk let rfk = RefLogKey @'HBS2Basic puk
privk <- findSk puk privk <- findSk puk
>>= orThrow TxKeyringNotFound >>= orThrow TxKeyringNotFound
@ -140,7 +140,7 @@ makeTx sto rewrite r puk findSk rh prev lbss = do
debug $ "update GK0 for existed block" <+> pretty bh debug $ "update GK0 for existed block" <+> pretty bh
let rcpt = HM.keys (recipients (wbeGk0 writeEnv)) let rcpt = HM.keys (recipients (wbeGk0 writeEnv))
gk1 <- generateGroupKey @HBS2Basic (Just gks) rcpt gk1 <- generateGroupKey @'HBS2Basic (Just gks) rcpt
gk1h <- writeAsMerkle sto (serialise gk1) gk1h <- writeAsMerkle sto (serialise gk1)
@ -166,7 +166,7 @@ makeTx sto rewrite r puk findSk rh prev lbss = do
& serialise & serialise
& LBS.toStrict & LBS.toStrict
makeRefLogUpdate @L4Proto @HBS2Basic puk privk tx makeRefLogUpdate @L4Proto @'HBS2Basic puk privk tx
unpackTx :: MonadIO m unpackTx :: MonadIO m

63
hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs Normal file
View File

@ -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

1
hbs2-git/hbs2-git.cabal
View File

@ -101,6 +101,7 @@ library
HBS2.Git.Local.CLI HBS2.Git.Local.CLI
HBS2.Git.Data.Tx.Git HBS2.Git.Data.Tx.Git
HBS2.Git.Data.Tx.Index
HBS2.Git.Data.GK HBS2.Git.Data.GK
HBS2.Git.Data.RefLog HBS2.Git.Data.RefLog
HBS2.Git.Data.LWWBlock HBS2.Git.Data.LWWBlock

4
hbs2-keyman/app/Main.hs
View File

@ -33,7 +33,7 @@ type Command m = m ()
globalOptions :: Parser GlobalOptions globalOptions :: Parser GlobalOptions
globalOptions = pure 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) commands :: (AppPerks m) => Parser (Command m)
@ -93,7 +93,7 @@ updateKeys = do
bs <- liftIO $ BS.readFile fn bs <- liftIO $ BS.readFile fn
krf <- parseCredentials @HBS2Basic (AsCredFile bs) & toMPlus krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
let skp = view peerSignPk krf let skp = view peerSignPk krf

16
hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs
View File

@ -51,10 +51,10 @@ runKeymanClient action = do
loadCredentials :: forall a m . loadCredentials :: forall a m .
( MonadIO m ( MonadIO m
, SomePubKeyPerks a , SomePubKeyPerks a
, SerialisedCredentials HBS2Basic , SerialisedCredentials 'HBS2Basic
) )
=> a => a
-> KeyManClient m (Maybe (PeerCredentials HBS2Basic)) -> KeyManClient m (Maybe (PeerCredentials 'HBS2Basic))
loadCredentials k = KeyManClient do loadCredentials k = KeyManClient do
fnames <- select @(Only FilePath) [qc| fnames <- select @(Only FilePath) [qc|
@ -71,10 +71,10 @@ loadCredentials k = KeyManClient do
loadKeyRingEntry :: forall m . loadKeyRingEntry :: forall m .
( MonadIO m ( MonadIO m
, SerialisedCredentials HBS2Basic , SerialisedCredentials 'HBS2Basic
) )
=> PubKey 'Encrypt HBS2Basic => PubKey 'Encrypt 'HBS2Basic
-> KeyManClient m (Maybe (KeyringEntry HBS2Basic)) -> KeyManClient m (Maybe (KeyringEntry 'HBS2Basic))
loadKeyRingEntry pk = KeyManClient do loadKeyRingEntry pk = KeyManClient do
runMaybeT do runMaybeT do
fn <- toMPlus =<< lift (selectKeyFile pk) fn <- toMPlus =<< lift (selectKeyFile pk)
@ -87,10 +87,10 @@ loadKeyRingEntry pk = KeyManClient do
loadKeyRingEntries :: forall m . loadKeyRingEntries :: forall m .
( MonadIO m ( MonadIO m
, SerialisedCredentials HBS2Basic , SerialisedCredentials 'HBS2Basic
) )
=> [PubKey 'Encrypt HBS2Basic] => [PubKey 'Encrypt 'HBS2Basic]
-> KeyManClient m [(Word, KeyringEntry HBS2Basic)] -> KeyManClient m [(Word, KeyringEntry 'HBS2Basic)]
loadKeyRingEntries pks = KeyManClient do loadKeyRingEntries pks = KeyManClient do
r <- for pks $ \pk -> runMaybeT do r <- for pks $ \pk -> runMaybeT do
fn <- lift (selectKeyFile pk) >>= toMPlus fn <- lift (selectKeyFile pk) >>= toMPlus

7
hbs2-peer/app/BlockDownload.hs
View File

@ -730,10 +730,11 @@ blockDownloadLoop env0 = do
updatePeerInfo False p pinfo updatePeerInfo False p pinfo
processBlock :: forall e m . ( MonadIO m processBlock :: forall e s m . ( MonadIO m
, HasStorage m , HasStorage m
, MyPeer e , MyPeer e
, ForSignedBox e , ForSignedBox s
, s ~ Encryption e
, HasPeerLocator e (BlockDownloadM e m) , HasPeerLocator e (BlockDownloadM e m)
) )
=> Hash HbSync => Hash HbSync
@ -820,7 +821,7 @@ processBlock h = do
bs <- MaybeT $ pure block bs <- MaybeT $ pure block
-- TODO: check-if-we-somehow-trust-this-key -- 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 & either (const Nothing) unboxBundleRef
debug $ "GOT BundleRefValue" <+> parens (pretty ref) debug $ "GOT BundleRefValue" <+> parens (pretty ref)

2
hbs2-peer/app/CLI/Common.hs
View File

@ -61,5 +61,5 @@ pRpcCommon = do
RPCOpt <$> optional confOpt RPCOpt <$> optional confOpt
<*> optional rpcOpt <*> optional rpcOpt
pPubKey :: ReadM (PubKey 'Sign HBS2Basic) pPubKey :: ReadM (PubKey 'Sign 'HBS2Basic)
pPubKey = maybeReader fromStringMay pPubKey = maybeReader fromStringMay

7
hbs2-peer/app/CLI/LWWRef.hs
View File

@ -5,7 +5,6 @@ import HBS2.OrDie
import HBS2.Net.Proto.Service import HBS2.Net.Proto.Service
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Data.Types.SignedBox import HBS2.Data.Types.SignedBox
import HBS2.Net.Auth.Schema
import HBS2.Peer.Proto.LWWRef import HBS2.Peer.Proto.LWWRef
import HBS2.Peer.RPC.API.LWWRef import HBS2.Peer.RPC.API.LWWRef
@ -35,8 +34,8 @@ pLwwRefFetch = do
Left e -> err (viaShow e) >> exitFailure Left e -> err (viaShow e) >> exitFailure
Right{} -> pure () Right{} -> pure ()
lwwRef :: ReadM (LWWRefKey HBS2Basic) lwwRef :: ReadM (LWWRefKey 'HBS2Basic)
lwwRef = maybeReader (fromStringMay @(LWWRefKey HBS2Basic)) lwwRef = maybeReader (fromStringMay @(LWWRefKey 'HBS2Basic))
pLwwRefGet :: Parser (IO ()) pLwwRefGet :: Parser (IO ())
pLwwRefGet = do pLwwRefGet = do
@ -69,7 +68,7 @@ pLwwRefUpdate = do
Right Nothing -> err ("not found value for" <+> pretty ref) >> exitFailure Right Nothing -> err ("not found value for" <+> pretty ref) >> exitFailure
Right (Just r) -> pure $ succ (lwwSeq r) 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 callService @RpcLWWRefUpdate caller box >>= \case
Left e -> err (viaShow e) >> exitFailure Left e -> err (viaShow e) >> exitFailure
Right r -> print $ pretty r Right r -> print $ pretty r

20
hbs2-peer/app/CLI/RefChan.hs
View File

@ -76,7 +76,7 @@ pRefChanHeadGen = do
s <- maybe1 fn getContents readFile s <- maybe1 fn getContents readFile
hd <- pure (fromStringMay @(RefChanHeadBlock L4Proto) s) `orDie` "can't generate head block" 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) LBS.putStr (serialise qq)
pRefChanHeadDump :: Parser (IO ()) pRefChanHeadDump :: Parser (IO ())
@ -84,7 +84,7 @@ pRefChanHeadDump= do
fn <- optional $ strArgument (metavar "refchan head blob") fn <- optional $ strArgument (metavar "refchan head blob")
pure $ do pure $ do
lbs <- maybe1 fn LBS.getContents LBS.readFile 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 print $ pretty hdblk
@ -130,7 +130,7 @@ pRefChanPropose = do
lbs <- maybe1 fn LBS.getContents LBS.readFile 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 if dry then do
LBS.putStr (serialise box) LBS.putStr (serialise box)
@ -178,15 +178,15 @@ pRefChanNotifyPost = do
-- caller <- ContT $ withMyRPC @RefChanAPI opts -- caller <- ContT $ withMyRPC @RefChanAPI opts
sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58 @(Sigil L4Proto)) sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58)
`orDie` "parse sigil failed" `orDie` "parse sigil failed"
(auPk, sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) (auPk, sd) <- pure (unboxSignedBox0 (sigilData sigil))
>>= orThrowUser "malformed sigil/bad signature" >>= orThrowUser "malformed sigil/bad signature"
keys <- liftIO $ runKeymanClient do keys <- liftIO $ runKeymanClient do
creds <- loadCredentials auPk >>= orThrowUser "can't load credentials" creds <- loadCredentials auPk >>= orThrowUser "can't load credentials"
encKey <- loadKeyRingEntry (sigilDataEncKey sd) encKey <- loadKeyRingEntry (sigilDataEncKey @'HBS2Basic sd)
pure (creds,encKey) pure (creds,encKey)
let creds = view _1 keys let creds = view _1 keys
@ -253,7 +253,7 @@ pRefChanNotifyPost = do
gks <- runExceptT (readFromMerkle sto (SimpleKey gkv)) gks <- runExceptT (readFromMerkle sto (SimpleKey gkv))
>>= toMPlus >>= toMPlus
gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gks gk <- deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) gks
& toMPlus & toMPlus
notice $ "found GK0" <+> pretty gkv notice $ "found GK0" <+> pretty gkv
@ -263,7 +263,7 @@ pRefChanNotifyPost = do
gk <- case mgk of gk <- case mgk of
Just x -> pure x Just x -> pure x
Nothing -> do Nothing -> do
gknew <- generateGroupKey @HBS2Basic Nothing (HashSet.toList rcpts) gknew <- generateGroupKey @'HBS2Basic Nothing (HashSet.toList rcpts)
gkh <- writeAsMerkle sto (serialise gknew) gkh <- writeAsMerkle sto (serialise gknew)
@ -281,7 +281,7 @@ pRefChanNotifyPost = do
-- FIXME: use-deterministic-nonce -- FIXME: use-deterministic-nonce
lift $ encryptBlock sto gks (Right gk) Nothing lbs <&> serialise 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) void $ callService @RpcRefChanNotify refChanAPI (puk, box)
where where
@ -368,7 +368,7 @@ pRefChanGK = do
let readers = view refChanHeadReaders' hd let readers = view refChanHeadReaders' hd
gk <- generateGroupKey @HBS2Basic Nothing (HashSet.toList readers) gk <- generateGroupKey @'HBS2Basic Nothing (HashSet.toList readers)
liftIO $ print $ pretty (AsGroupKeyFile gk) liftIO $ print $ pretty (AsGroupKeyFile gk)

6
hbs2-peer/app/HttpWorker.hs
View File

@ -93,16 +93,16 @@ httpWorker (PeerConfig syn) pmeta e = do
get "/ref/:key" do get "/ref/:key" do
void $ flip runContT pure 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) >>= orElse (status status404)
rv <- getRef sto what rv <- getRef sto what
>>= orElse (status status404) >>= orElse (status status404)
>>= getBlock sto >>= getBlock sto
>>= orElse (status status404) >>= orElse (status status404)
<&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef e) e) <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef s) s)
>>= orElse (status status404) >>= orElse (status status404)
<&> unboxSignedBox0 @(LWWRef e) <&> unboxSignedBox0 @(LWWRef s)
>>= orElse (status status404) >>= orElse (status status404)
<&> lwwValue . snd <&> lwwValue . snd

2
hbs2-peer/app/PeerConfig.hs
View File

@ -126,7 +126,7 @@ peerConfigInit mbfp = liftIO do
appendFile cfgPath ";; hbs2-peer config file" appendFile cfgPath ";; hbs2-peer config file"
appendFile cfgPath defConfigData appendFile cfgPath defConfigData
cred0 <- newCredentials @HBS2Basic cred0 <- newCredentials @'HBS2Basic
let keyname = "default.key" let keyname = "default.key"
let keypath = dir</>keyname let keypath = dir</>keyname

6
hbs2-peer/app/PeerMain.hs
View File

@ -284,7 +284,7 @@ runCLI = do
pVersion = pure do pVersion = pure do
LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version) LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version)
pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic)) pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))
pRun = do pRun = do
runPeer <$> common runPeer <$> common
@ -586,7 +586,7 @@ runCLI = do
void $ runMaybeT do void $ runMaybeT do
void $ callService @RpcPerformGC caller () void $ callService @RpcPerformGC caller ()
refP :: ReadM (PubKey 'Sign HBS2Basic) refP :: ReadM (PubKey 'Sign 'HBS2Basic)
refP = maybeReader fromStringMay refP = maybeReader fromStringMay
hashP :: ReadM HashRef hashP :: ReadM HashRef
@ -1124,7 +1124,7 @@ runPeer opts = Exception.handle (\e -> myException e
blk1 <- liftIO $ getBlock sto ha blk1 <- liftIO $ getBlock sto ha
maybe1 blk1 none S.yield 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 case box of
-- FIXME: proper-error-handling -- FIXME: proper-error-handling

4
hbs2-peer/app/PeerTypes.hs
View File

@ -131,7 +131,7 @@ type MyPeer e = ( Eq (Peer e)
, Hashable (Peer e) , Hashable (Peer e)
, Pretty (Peer e) , Pretty (Peer e)
, HasPeer e , HasPeer e
, ForSignedBox e , ForSignedBox (Encryption e)
) )
data DownloadReq e data DownloadReq e
@ -162,7 +162,7 @@ instance Expires (EventKey e (DownloadReq e)) where
type DownloadFromPeerStuff e m = ( MyPeer e type DownloadFromPeerStuff e m = ( MyPeer e
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
, ForSignedBox e , ForSignedBox (Encryption e)
, Request e (BlockInfo e) m , Request e (BlockInfo e) m
, Request e (BlockChunks e) m , Request e (BlockChunks e) m
, MonadReader (PeerEnv e ) m , MonadReader (PeerEnv e ) m

4
hbs2-peer/app/RPC2/LWWRef.hs
View File

@ -41,7 +41,7 @@ instance (LWWRefContext m) => HandleMethod m RpcLWWRefGet where
runMaybeT do runMaybeT do
rv <- getRef sto key >>= toMPlus rv <- getRef sto key >>= toMPlus
val <- getBlock sto rv >>= toMPlus val <- getBlock sto rv >>= toMPlus
<&> unboxSignedBox @(LWWRef L4Proto) @L4Proto <&> unboxSignedBox @(LWWRef 'HBS2Basic) @HBS2Basic
>>= toMPlus >>= toMPlus
pure $ snd val pure $ snd val
@ -72,6 +72,6 @@ instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where
liftIO $ withPeerM penv do liftIO $ withPeerM penv do
me <- ownPeer @L4Proto me <- ownPeer @L4Proto
runResponseM me $ do runResponseM me $ do
lwwRefProto nada (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box)) lwwRefProto nada (LWWRefProto1 @L4Proto (LWWProtoSet (LWWRefKey puk) box))

4
hbs2-peer/app/RPC2/RefChan.hs
View File

@ -37,7 +37,7 @@ instance RefChanContext m => HandleMethod m RpcRefChanHeadGet where
debug $ "rpc.refchanHeadGet:" <+> pretty (AsBase58 puk) debug $ "rpc.refchanHeadGet:" <+> pretty (AsBase58 puk)
liftIO $ withPeerM penv $ do liftIO $ withPeerM penv $ do
sto <- getStorage 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 instance (RefChanContext m) => HandleMethod m RpcRefChanHeadFetch where
@ -63,7 +63,7 @@ instance RefChanContext m => HandleMethod m RpcRefChanGet where
debug $ "rpc.refchanGet:" <+> pretty (AsBase58 puk) debug $ "rpc.refchanGet:" <+> pretty (AsBase58 puk)
liftIO $ withPeerM penv $ do liftIO $ withPeerM penv $ do
sto <- getStorage 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 instance RefChanContext m => HandleMethod m RpcRefChanPropose where

4
hbs2-peer/app/RPC2/RefLog.hs
View File

@ -37,11 +37,11 @@ instance (RefLogContext m) => HandleMethod m RpcRefLogGet where
handleMethod pk = do handleMethod pk = do
co <- getRpcContext @RefLogAPI co <- getRpcContext @RefLogAPI
debug $ "rpc.reflogGet:" <+> pretty (AsBase58 pk) debug $ "rpc.reflogGet:" <+> pretty (AsBase58 pk)
<+> pretty (hashObject @HbSync (RefLogKey @HBS2Basic pk)) <+> pretty (hashObject @HbSync (RefLogKey @'HBS2Basic pk))
liftIO $ withPeerM (rpcPeerEnv co) $ do liftIO $ withPeerM (rpcPeerEnv co) $ do
let sto = rpcStorage co 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 instance (RefLogContext m) => HandleMethod m RpcRefLogFetch where

6
hbs2-peer/app/RefChan.hs
View File

@ -721,7 +721,7 @@ refChanWorker env brains = do
trace $ "BLOCK IS HERE" <+> pretty hr trace $ "BLOCK IS HERE" <+> pretty hr
-- читаем блок -- читаем блок
lbs <- readBlobFromTree (getBlock sto) hr <&> fromMaybe mempty lbs <- readBlobFromTree (getBlock sto) hr <&> fromMaybe mempty
let what = unboxSignedBox @(RefChanHeadBlock e) @e lbs let what = unboxSignedBox @(RefChanHeadBlock e) @s lbs
notify <- atomically $ do notify <- atomically $ do
no <- readTVar (_refChanWorkerEnvNotify env) <&> HashMap.member chan no <- readTVar (_refChanWorkerEnvNotify env) <&> HashMap.member chan
@ -742,7 +742,7 @@ refChanWorker env brains = do
lbss <- MaybeT $ readBlobFromTree (getBlock sto) (HashRef cur) 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 pure $ view refChanHeadVersion blkOur
@ -863,7 +863,7 @@ logMergeProcess penv env q = withPeerM penv do
Just x -> pure (Just x) Just x -> pure (Just x)
Nothing -> runMaybeT do Nothing -> runMaybeT do
hdblob <- MaybeT $ readBlobFromTree ( liftIO . getBlock sto ) h 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) atomically $ modifyTVar (mergeHeads e) (HashMap.insert h headblk)
pure headblk pure headblk

1
hbs2-peer/hbs2-peer.cabal
View File

@ -30,6 +30,7 @@ common common-deps
, dns , dns
, filepath , filepath
, generic-lens , generic-lens
, generic-data
, hashable , hashable
, microlens-platform , microlens-platform
, mtl , mtl

2
hbs2-peer/lib/HBS2/Peer/Notify.hs
View File

@ -49,7 +49,7 @@ deriving newtype instance ForRefChans e => Hashable (NotifyKey (RefChanEvents e)
deriving newtype instance ForRefChans e => Eq (NotifyKey (RefChanEvents e)) deriving newtype instance ForRefChans e => Eq (NotifyKey (RefChanEvents e))
data instance NotifyData (RefChanEvents e) = data instance NotifyData (RefChanEvents e) =
RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString e) RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString (Encryption e))
deriving Generic deriving Generic
instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e)) instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e))

2
hbs2-peer/lib/HBS2/Peer/Proto.hs
View File

@ -148,7 +148,7 @@ instance HasProtocol L4Proto (RefChanNotify L4Proto) where
-- возьмем пока 10 секунд -- возьмем пока 10 секунд
requestPeriodLim = NoLimit requestPeriodLim = NoLimit
instance ForLWWRefProto L4Proto => HasProtocol L4Proto (LWWRefProto L4Proto) where instance HasProtocol L4Proto (LWWRefProto L4Proto) where
type instance ProtocolId (LWWRefProto L4Proto) = 12001 type instance ProtocolId (LWWRefProto L4Proto) = 12001
type instance Encoded L4Proto = ByteString type instance Encoded L4Proto = ByteString
decode = either (const Nothing) Just . deserialiseOrFail decode = either (const Nothing) Just . deserialiseOrFail

39
hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs
View File

@ -8,13 +8,10 @@ import HBS2.Base58
import HBS2.Storage import HBS2.Storage
import HBS2.Hash import HBS2.Hash
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Types
import HBS2.Data.Types.SignedBox import HBS2.Data.Types.SignedBox
import HBS2.Data.Types.Refs import HBS2.Data.Types.Refs
import HBS2.Net.Proto.Types
import HBS2.Net.Auth.Schema() import HBS2.Net.Auth.Schema()
import Data.ByteString (ByteString)
import Data.Hashable hiding (Hashed) import Data.Hashable hiding (Hashed)
import Data.Maybe import Data.Maybe
import Data.Word import Data.Word
@ -22,17 +19,17 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Except import Control.Monad.Except
import Codec.Serialise import Codec.Serialise
data LWWRefProtoReq e = data LWWRefProtoReq (s :: CryptoScheme) =
LWWProtoGet (LWWRefKey (Encryption e)) LWWProtoGet (LWWRefKey s)
| LWWProtoSet (LWWRefKey (Encryption e)) (SignedBox (LWWRef e) e) | LWWProtoSet (LWWRefKey s) (SignedBox (LWWRef s) s)
deriving stock Generic deriving stock Generic
data LWWRefProto e = data LWWRefProto e =
LWWRefProto1 (LWWRefProtoReq e) LWWRefProto1 (LWWRefProtoReq (Encryption e))
deriving stock (Generic) deriving stock (Generic)
data LWWRef e = data LWWRef (s :: CryptoScheme) =
LWWRef LWWRef
{ lwwSeq :: Word64 { lwwSeq :: Word64
, lwwValue :: HashRef , lwwValue :: HashRef
@ -40,12 +37,14 @@ data LWWRef e =
} }
deriving stock (Generic) 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 s => Serialise (LWWRefProtoReq s)
instance ForLWWRefProto e => Serialise (LWWRefProto e) instance ForLWWRefProto (Encryption e) => Serialise (LWWRefProto e)
instance ForLWWRefProto e => Serialise (LWWRef e) instance ForLWWRefProto s => Serialise (LWWRef s)
newtype LWWRefKey s = newtype LWWRefKey s =
LWWRefKey LWWRefKey
@ -96,30 +95,28 @@ data ReadLWWRefError =
| ReadLWWSignatureError | ReadLWWSignatureError
deriving stock (Show,Typeable) deriving stock (Show,Typeable)
readLWWRef :: forall e s m . ( MonadIO m readLWWRef :: forall s m . ( MonadIO m
, MonadError ReadLWWRefError m , MonadError ReadLWWRefError m
, Encryption e ~ s , ForLWWRefProto s
, ForLWWRefProto e
, Signatures s , Signatures s
, IsRefPubKey s , IsRefPubKey s
) )
=> AnyStorage => AnyStorage
-> LWWRefKey s -> LWWRefKey s
-> m (Maybe (LWWRef e)) -> m (Maybe (LWWRef s))
readLWWRef sto key = runMaybeT do readLWWRef sto key = runMaybeT do
getRef sto key getRef sto key
>>= toMPlus >>= toMPlus
>>= getBlock sto >>= getBlock sto
>>= toMPlus >>= toMPlus
<&> deserialiseOrFail @(SignedBox (LWWRef e) e) <&> deserialiseOrFail @(SignedBox (LWWRef s) s)
>>= orThrowError ReadLWWFormatError >>= orThrowError ReadLWWFormatError
<&> unboxSignedBox0 <&> unboxSignedBox0
>>= orThrowError ReadLWWSignatureError >>= orThrowError ReadLWWSignatureError
<&> snd <&> snd
updateLWWRef :: forall s e m . ( Encryption e ~ s updateLWWRef :: forall s m . ( ForLWWRefProto s
, ForLWWRefProto e
, MonadIO m , MonadIO m
, Signatures s , Signatures s
, IsRefPubKey s , IsRefPubKey s
@ -127,11 +124,11 @@ updateLWWRef :: forall s e m . ( Encryption e ~ s
=> AnyStorage => AnyStorage
-> LWWRefKey s -> LWWRefKey s
-> PrivKey 'Sign s -> PrivKey 'Sign s
-> LWWRef e -> LWWRef s
-> m (Maybe HashRef) -> m (Maybe HashRef)
updateLWWRef sto k sk v = do updateLWWRef sto k sk v = do
let box = makeSignedBox @e (fromLwwRefKey k) sk v let box = makeSignedBox @s (fromLwwRefKey k) sk v
runMaybeT do runMaybeT do
hx <- putBlock sto (serialise box) >>= toMPlus hx <- putBlock sto (serialise box) >>= toMPlus
updateRef sto k hx updateRef sto k hx

6
hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs
View File

@ -35,7 +35,7 @@ data LWWRefProtoAdapter e m =
} }
lwwRefProto :: forall e s m proto . ( MonadIO m lwwRefProto :: forall e s m proto . ( MonadIO m
, ForLWWRefProto e , ForLWWRefProto s
, Request e proto m , Request e proto m
, Response e proto m , Response e proto m
, HasDeferred proto e m , HasDeferred proto e m
@ -66,7 +66,7 @@ lwwRefProto adapter pkt@(LWWRefProto1 req) = do
<&> deserialiseOrFail <&> deserialiseOrFail
>>= toMPlus >>= toMPlus
lift $ response (LWWRefProto1 (LWWProtoSet @e key box)) lift $ response (LWWRefProto1 @e (LWWProtoSet key box))
LWWProtoSet key box -> void $ runMaybeT do LWWProtoSet key box -> void $ runMaybeT do
@ -97,7 +97,7 @@ lwwRefProto adapter pkt@(LWWRefProto1 req) = do
blk' <- getBlock sto rv blk' <- getBlock sto rv
maybe1 blk' (forcedUpdateLwwRef sto key bs) $ \blk -> do 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 & either (const Nothing) Just
>>= unboxSignedBox0 >>= unboxSignedBox0
<&> snd <&> snd

16
hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs
View File

@ -42,7 +42,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
import UnliftIO import UnliftIO
data ProposeTran e = ProposeTran HashRef (SignedBox ByteString e) -- произвольная бинарная транзакция, data ProposeTran e = ProposeTran HashRef (SignedBox ByteString (Encryption e)) -- произвольная бинарная транзакция,
deriving stock (Generic) -- подписанная ключом **АВТОРА**, который её рассылает deriving stock (Generic) -- подписанная ключом **АВТОРА**, который её рассылает
newtype AcceptTime = AcceptTime Word64 newtype AcceptTime = AcceptTime Word64
@ -126,8 +126,8 @@ instance Expires (EventKey e (RefChanRound e)) where
-- черт его знает, какой там останется пайлоад. -- черт его знает, какой там останется пайлоад.
-- надо посмотреть. байт, небось, 400 -- надо посмотреть. байт, небось, 400
data RefChanUpdate e = data RefChanUpdate e =
Propose (RefChanId e) (SignedBox (ProposeTran e) e) -- подписано ключом пира Propose (RefChanId e) (SignedBox (ProposeTran e) (Encryption e)) -- подписано ключом пира
| Accept (RefChanId e) (SignedBox (AcceptTran e) e) -- подписано ключом пира | Accept (RefChanId e) (SignedBox (AcceptTran e) (Encryption e)) -- подписано ключом пира
deriving stock (Generic) deriving stock (Generic)
instance ForRefChans e => Serialise (RefChanUpdate e) instance ForRefChans e => Serialise (RefChanUpdate e)
@ -381,7 +381,7 @@ refChanUpdateProto self pc adapter msg = do
let tran = AcceptTran ts headRef (HashRef hash) let tran = AcceptTran ts headRef (HashRef hash)
-- -- генерируем Accept -- -- генерируем Accept
let accept = Accept chan (makeSignedBox @e pk sk tran) let accept = Accept chan (makeSignedBox @s pk sk tran)
-- -- и рассылаем всем -- -- и рассылаем всем
debug "GOSSIP ACCEPT TRANSACTION" debug "GOSSIP ACCEPT TRANSACTION"
@ -443,7 +443,7 @@ refChanUpdateProto self pc adapter msg = do
_ -> Nothing _ -> 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 debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0
@ -572,8 +572,8 @@ makeProposeTran :: forall e s m . ( MonadIO m
) )
=> PeerCredentials s => PeerCredentials s
-> RefChanId e -> RefChanId e
-> SignedBox ByteString e -> SignedBox ByteString s
-> m (Maybe (SignedBox (ProposeTran e) e)) -> m (Maybe (SignedBox (ProposeTran e) s))
makeProposeTran creds chan box1 = do makeProposeTran creds chan box1 = do
sto <- getStorage sto <- getStorage
@ -582,7 +582,7 @@ makeProposeTran creds chan box1 = do
let tran = ProposeTran @e (HashRef h) box1 let tran = ProposeTran @e (HashRef h) box1
let pk = view peerSignPk creds let pk = view peerSignPk creds
let sk = view peerSignSk creds let sk = view peerSignSk creds
pure $ makeSignedBox @e pk sk tran pure $ makeSignedBox @s pk sk tran
-- FIXME: reconnect-validator-client-after-restart -- FIXME: reconnect-validator-client-after-restart
-- почему-то сейчас если рестартовать пира, -- почему-то сейчас если рестартовать пира,

5
hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs
View File

@ -88,7 +88,7 @@ data RefChanActionRequest =
instance Serialise RefChanActionRequest instance Serialise RefChanActionRequest
data RefChanNotify e = data RefChanNotify e =
Notify (RefChanId e) (SignedBox ByteString e) -- подписано ключом автора Notify (RefChanId e) (SignedBox ByteString (Encryption e)) -- подписано ключом автора
-- довольно уместно будет добавить эти команды сюда - -- довольно уместно будет добавить эти команды сюда -
-- они постоянно нужны, и это сильно упростит коммуникации -- они постоянно нужны, и это сильно упростит коммуникации
| ActionRequest (RefChanId e) RefChanActionRequest | ActionRequest (RefChanId e) RefChanActionRequest
@ -128,7 +128,6 @@ type ForRefChans e = ( Serialise ( PubKey 'Sign (Encryption e))
) )
refChanHeadReaders :: ForRefChans e refChanHeadReaders :: ForRefChans e
=> Lens (RefChanHeadBlock e) => Lens (RefChanHeadBlock e)
(RefChanHeadBlock e) (RefChanHeadBlock e)
@ -367,7 +366,7 @@ getRefChanHead :: forall e s m . ( MonadIO m
getRefChanHead sto k = runMaybeT do getRefChanHead sto k = runMaybeT do
h <- MaybeT $ liftIO $ getRef sto k h <- MaybeT $ liftIO $ getRef sto k
hdblob <- MaybeT $ readBlobFromTree ( getBlock sto ) (HashRef h) 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 pure headblk

10
hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs
View File

@ -4,9 +4,7 @@ import HBS2.Peer.Prelude
import HBS2.Peer.Proto.LWWRef import HBS2.Peer.Proto.LWWRef
import HBS2.Data.Types.SignedBox import HBS2.Data.Types.SignedBox
import HBS2.Net.Messaging.Unix import HBS2.Net.Messaging.Unix
import HBS2.Data.Types.Refs (HashRef(..))
import HBS2.Net.Proto.Service import HBS2.Net.Proto.Service
import HBS2.Peer.Proto.RefLog (RefLogUpdate)
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Codec.Serialise import Codec.Serialise
@ -26,13 +24,13 @@ instance HasProtocol UNIX (ServiceProto LWWRefAPI UNIX) where
decode = either (const Nothing) Just . deserialiseOrFail decode = either (const Nothing) Just . deserialiseOrFail
encode = serialise encode = serialise
type instance Input RpcLWWRefGet = LWWRefKey HBS2Basic type instance Input RpcLWWRefGet = LWWRefKey 'HBS2Basic
type instance Output RpcLWWRefGet = Maybe (LWWRef L4Proto) 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 Output RpcLWWRefFetch = ()
type instance Input RpcLWWRefUpdate = SignedBox (LWWRef L4Proto) L4Proto type instance Input RpcLWWRefUpdate = SignedBox (LWWRef 'HBS2Basic) 'HBS2Basic
type instance Output RpcLWWRefUpdate = () type instance Output RpcLWWRefUpdate = ()

8
hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs
View File

@ -79,13 +79,13 @@ type instance Input RpcPexInfo = ()
type instance Output RpcPexInfo = [PeerAddr L4Proto] type instance Output RpcPexInfo = [PeerAddr L4Proto]
type instance Input RpcPeers = () 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 Input RpcFetch = HashRef
type instance Output RpcFetch = () type instance Output RpcFetch = ()
type instance Input RpcPollList= () 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 Input RpcDownloadList = ()
type instance Output RpcDownloadList = [(HashRef, Integer)] type instance Output RpcDownloadList = [(HashRef, Integer)]
@ -93,10 +93,10 @@ type instance Output RpcDownloadList = [(HashRef, Integer)]
type instance Input RpcDownloadDel = HashRef type instance Input RpcDownloadDel = HashRef
type instance Output RpcDownloadDel = () 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 Output RpcPollAdd = ()
type instance Input RpcPollDel = PubKey 'Sign HBS2Basic type instance Input RpcPollDel = PubKey 'Sign 'HBS2Basic
type instance Output RpcPollDel = () type instance Output RpcPollDel = ()
type instance Input RpcLogLevel = SetLogging type instance Input RpcLogLevel = SetLogging

12
hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs
View File

@ -43,22 +43,22 @@ instance HasProtocol UNIX (ServiceProto RefChanAPI UNIX) where
encode = serialise encode = serialise
type instance Input RpcRefChanHeadGet = PubKey 'Sign HBS2Basic type instance Input RpcRefChanHeadGet = PubKey 'Sign 'HBS2Basic
type instance Output RpcRefChanHeadGet = Maybe HashRef 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 Output RpcRefChanHeadFetch = ()
type instance Input RpcRefChanFetch = PubKey 'Sign HBS2Basic type instance Input RpcRefChanFetch = PubKey 'Sign 'HBS2Basic
type instance Output RpcRefChanFetch = () 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 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 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 Output RpcRefChanNotify = ()
type instance Input RpcRefChanHeadPost = HashRef type instance Input RpcRefChanHeadPost = HashRef

4
hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs
View File

@ -27,10 +27,10 @@ instance HasProtocol UNIX (ServiceProto RefLogAPI UNIX) where
decode = either (const Nothing) Just . deserialiseOrFail decode = either (const Nothing) Just . deserialiseOrFail
encode = serialise encode = serialise
type instance Input RpcRefLogGet = PubKey 'Sign HBS2Basic type instance Input RpcRefLogGet = PubKey 'Sign 'HBS2Basic
type instance Output RpcRefLogGet = Maybe HashRef 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 Output RpcRefLogFetch = ()
type instance Input RpcRefLogPost = RefLogUpdate L4Proto type instance Input RpcRefLogPost = RefLogUpdate L4Proto

4
hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
View File

@ -36,8 +36,8 @@ data RPC2Context =
, rpcByPassInfo :: IO ByPassStat , rpcByPassInfo :: IO ByPassStat
, rpcDoFetch :: HashRef -> IO () , rpcDoFetch :: HashRef -> IO ()
, rpcDoRefChanHeadPost :: HashRef -> IO () , rpcDoRefChanHeadPost :: HashRef -> IO ()
, rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () , rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
, rpcDoRefChanNotify :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () , rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
} }
instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where

10
hbs2-peer/test/TestSuite.hs
View File

@ -50,17 +50,17 @@ testVersionedKeysHashes = do
& orThrowUser "bad base58" & orThrowUser "bad base58"
<&> LBS.fromStrict <&> LBS.fromStrict
pk <- fromStringMay @(PubKey 'Sign HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" pk <- fromStringMay @(PubKey 'Sign 'HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
& orThrowUser "key decode" & orThrowUser "key decode"
let pks = serialise pk let pks = serialise pk
pks2 <- deserialiseOrFail @(PubKey 'Sign HBS2Basic) (pks <> "12345") pks2 <- deserialiseOrFail @(PubKey 'Sign 'HBS2Basic) (pks <> "12345")
& orThrowUser "key decode error" & orThrowUser "key decode error"
let rfk = serialise (RefLogKey @HBS2Basic pk) let rfk = serialise (RefLogKey @'HBS2Basic pk)
let wrfk = serialise $ W (RefLogKey @HBS2Basic pk) let wrfk = serialise $ W (RefLogKey @'HBS2Basic pk)
let xrfk = serialise $ X (RefLogKey @HBS2Basic pk) let xrfk = serialise $ X (RefLogKey @'HBS2Basic pk)
print $ pretty (AsHexSparse keypart) print $ pretty (AsHexSparse keypart)
print $ pretty (AsHexSparse pks) print $ pretty (AsHexSparse pks)

23
hbs2-share/src/HBS2/Share/App.hs
View File

@ -169,8 +169,8 @@ makeGK0Key rpc = runMaybeT do
getGK0 :: forall e s m . ( AppPerks m getGK0 :: forall e s m . ( AppPerks m
, HasProtocol e (ServiceProto StorageAPI e) , HasProtocol e (ServiceProto StorageAPI e)
, ForGroupKeySymm HBS2Basic , ForGroupKeySymm 'HBS2Basic
, s ~ HBS2Basic , s ~ 'HBS2Basic
) )
=> RpcEndpoints e => RpcEndpoints e
-> ShareCLI m (GK0 s) -> ShareCLI m (GK0 s)
@ -273,10 +273,9 @@ withRpcClientUnix action = do
pure r pure r
loadSigil :: forall e s m . ( s ~ Encryption e loadSigil :: forall s m . ( ForSigil s
, ForSigil e
, AppPerks m , AppPerks m
) => ShareCLI m (PubKey 'Sign s, SigilData e) ) => ShareCLI m (PubKey 'Sign s, SigilData s)
loadSigil = do loadSigil = do
dir <- getLocalConfigDir dir <- getLocalConfigDir
@ -293,10 +292,10 @@ loadSigil = do
trace $ "SIGIL PATH" <+> pretty path 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) >>= 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 pure w
@ -304,7 +303,7 @@ loadAllEncryptionStuff :: AppPerks m => ShareCLI m ()
loadAllEncryptionStuff = do loadAllEncryptionStuff = do
-- 1. загружаем sigil -- 1. загружаем sigil
(pk, sd) <- loadSigil @L4Proto (pk, sd) <- loadSigil @'HBS2Basic
trace $ "sigil loaded" <+> pretty (AsBase58 pk) trace $ "sigil loaded" <+> pretty (AsBase58 pk)
@ -640,7 +639,7 @@ updateLocalState = do
postState :: forall e s m . ( AppPerks m postState :: forall e s m . ( AppPerks m
, HasProtocol e (ServiceProto RefChanAPI e) , HasProtocol e (ServiceProto RefChanAPI e)
, HasProtocol e (ServiceProto StorageAPI e) , HasProtocol e (ServiceProto StorageAPI e)
, s ~ HBS2Basic , s ~ 'HBS2Basic
) )
=> RpcEndpoints e => RpcEndpoints e
@ -755,7 +754,7 @@ postState rpc px = do
let ssk = view (creds . peerSignSk) encStuff let ssk = view (creds . peerSignSk) encStuff
let spk = view (creds . peerSignPk) 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 dont <- lift dontPost
@ -765,7 +764,7 @@ postState rpc px = do
pure () pure ()
where where
-- genTreeOverride :: AnyStorage -> EncryptionStuff -> GK0 HBS2Basic -> HashRef -> m () -- genTreeOverride :: AnyStorage -> EncryptionStuff -> GK0 'HBS2Basic -> HashRef -> m ()
genTreeOverride sto enc gk0 tree = do genTreeOverride sto enc gk0 tree = do
let (KeyringKeys pk sk) = view kre enc let (KeyringKeys pk sk) = view kre enc
runMaybeT do runMaybeT do
@ -819,7 +818,7 @@ runSync = do
updateLocalState updateLocalState
postState rpc px 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 => GroupSecret
-> GroupKey 'Symm s -> GroupKey 'Symm s
-> AnyStorage -> AnyStorage

4
hbs2-share/src/HBS2/Share/App/Types.hs
View File

@ -54,8 +54,8 @@ data RpcEndpoints e =
data EncryptionStuff = data EncryptionStuff =
EncryptionStuff EncryptionStuff
{ _creds :: PeerCredentials HBS2Basic { _creds :: PeerCredentials 'HBS2Basic
, _kre :: KeyringEntry HBS2Basic , _kre :: KeyringEntry 'HBS2Basic
} }
makeLenses ''EncryptionStuff makeLenses ''EncryptionStuff

2
hbs2-tests/test/TestRawTx.hs
View File

@ -48,7 +48,7 @@ main = do
<> header "Raw tx test" <> header "Raw tx test"
) )
krData <- BS.readFile $ credentialsFile options 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 pubk = view peerSignPk creds
let privk = view peerSignSk creds let privk = view peerSignSk creds
bs <- pure (fromBase58 $ BS8.pack $ tx options) `orDie` "transaction is not in Base58 format" bs <- pure (fromBase58 $ BS8.pack $ tx options) `orDie` "transaction is not in Base58 format"

68
hbs2/Main.hs
View File

@ -110,7 +110,7 @@ newtype OptGroupkeyFile = OptGroupkeyFile { unOptGroupkeyFile :: FilePath }
deriving newtype (Eq,Ord,IsString) deriving newtype (Eq,Ord,IsString)
deriving stock (Data) deriving stock (Data)
newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt HBS2Basic } newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt 'HBS2Basic }
deriving newtype (Eq,Ord) deriving newtype (Eq,Ord)
deriving stock (Data) deriving stock (Data)
@ -151,8 +151,8 @@ newtype NewRefOpts =
deriving stock (Data) deriving stock (Data)
data EncSchema = EncSymm (GroupKey 'Symm HBS2Basic) data EncSchema = EncSymm (GroupKey 'Symm 'HBS2Basic)
| EncAsymm (GroupKey 'Asymm HBS2Basic) | EncAsymm (GroupKey 'Asymm 'HBS2Basic)
hPrint :: (MonadIO m, Show a) => Handle -> a -> m () hPrint :: (MonadIO m, Show a) => Handle -> a -> m ()
@ -183,7 +183,7 @@ runHash opts _ = do
withBinaryFile (hashFp opts) ReadMode $ \h -> do withBinaryFile (hashFp opts) ReadMode $ \h -> do
LBS.hGetContents h >>= print . pretty . hashObject @HbSync 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 runCat opts ss | catRaw opts == Just True = do
@ -242,7 +242,7 @@ runCat opts ss = do
keyring <- case uniLastMay @OptKeyringFile opts of keyring <- case uniLastMay @OptKeyringFile opts of
Just krf -> do Just krf -> do
s <- BS.readFile (unOptKeyringFile krf) 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 pure $ view peerKeyring cred
Nothing -> fromMaybe mempty <$> runMaybeT do Nothing -> fromMaybe mempty <$> runMaybeT do
@ -319,7 +319,7 @@ runStore opts ss = runResourceT do
Just gkfile -> 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 let mbGk = EncSymm <$> gkSymm
@ -331,7 +331,7 @@ runStore opts ss = runResourceT do
krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set" krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set"
s <- liftIO $ BS.readFile (unOptKeyringFile krf) 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) sk <- pure (headMay [ (view krPk k, view krSk k)
| k <- view peerKeyring cred | k <- view peerKeyring cred
@ -380,7 +380,7 @@ runStore opts ss = runResourceT do
hPrint stdout $ "merkle-ann-root: " <+> pretty mannh hPrint stdout $ "merkle-ann-root: " <+> pretty mannh
runNewGroupKeyAsymm :: forall s . (s ~ HBS2Basic) => FilePath -> IO () runNewGroupKeyAsymm :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO ()
runNewGroupKeyAsymm pubkeysFile = do runNewGroupKeyAsymm pubkeysFile = do
s <- BS.readFile pubkeysFile s <- BS.readFile pubkeysFile
pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file" 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 List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk
print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey 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 runNewKey n = do
cred0 <- newCredentials @s cred0 <- newCredentials @s
cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n] cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
print $ pretty $ AsCredFile $ AsBase58 cred print $ pretty $ AsCredFile $ AsBase58 cred
runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO () runListKeys :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO ()
runListKeys fp = do runListKeys fp = do
s <- BS.readFile fp s <- BS.readFile fp
cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file" cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file"
print $ pretty (ListKeyringKeys cred) print $ pretty (ListKeyringKeys cred)
runKeyAdd :: forall s . (s ~ HBS2Basic) => FilePath -> IO () runKeyAdd :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO ()
runKeyAdd fp = do runKeyAdd fp = do
hPrint stderr $ "adding a key into keyring" <+> pretty fp hPrint stderr $ "adding a key into keyring" <+> pretty fp
s <- BS.readFile fp s <- BS.readFile fp
@ -410,7 +410,7 @@ runKeyAdd fp = do
credNew <- addKeyPair Nothing cred credNew <- addKeyPair Nothing cred
print $ pretty $ AsCredFile $ AsBase58 credNew 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 runKeyDel n fp = do
hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp
s <- BS.readFile fp s <- BS.readFile fp
@ -419,7 +419,7 @@ runKeyDel n fp = do
print $ pretty $ AsCredFile $ AsBase58 credNew print $ pretty $ AsCredFile $ AsBase58 credNew
runShowPeerKey :: forall s . ( s ~ HBS2Basic) => Maybe FilePath -> IO () runShowPeerKey :: forall s . ( s ~ 'HBS2Basic) => Maybe FilePath -> IO ()
runShowPeerKey fp = do runShowPeerKey fp = do
handle <- maybe (pure stdin) (`openFile` ReadMode) fp handle <- maybe (pure stdin) (`openFile` ReadMode) fp
bs <- LBS.hGet handle 4096 <&> LBS.toStrict bs <- LBS.hGet handle 4096 <&> LBS.toStrict
@ -541,7 +541,7 @@ main = join . customExecParser (prefs showHelpOnError) $
epk :: ReadM OptEncPubKey epk :: ReadM OptEncPubKey
epk = eitherReader $ \arg -> do 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) maybe1 mpk (Left "invalid public key") (pure . OptEncPubKey)
pCat = do pCat = do
@ -641,24 +641,24 @@ main = join . customExecParser (prefs showHelpOnError) $
pure $ do pure $ do
members <- for fns $ \fn -> do members <- for fns $ \fn -> do
sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil L4Proto)) sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil 'HBS2Basic))
`orDie` "parse sigil failed" `orDie` "parse sigil failed"
(_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
`orDie` ("signature check failed " <> fn) `orDie` ("signature check failed " <> fn)
pure (sigilDataEncKey sd) pure (sigilDataEncKey sd)
gk <- Symm.generateGroupKey @HBS2Basic Nothing members gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
print $ pretty (AsGroupKeyFile gk) print $ pretty (AsGroupKeyFile gk)
pGroupKeyFromKeys = do pGroupKeyFromKeys = do
pure $ do pure $ do
input <- getContents <&> words input <- getContents <&> words
members <- for input $ \s -> do members <- for input $ \s -> do
fromStringMay @(PubKey 'Encrypt HBS2Basic) s fromStringMay @(PubKey 'Encrypt 'HBS2Basic) s
& maybe (die "invalid public key") pure & maybe (die "invalid public key") pure
gk <- Symm.generateGroupKey @HBS2Basic Nothing members gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
print $ pretty (AsGroupKeyFile gk) print $ pretty (AsGroupKeyFile gk)
@ -667,18 +667,18 @@ main = join . customExecParser (prefs showHelpOnError) $
pure $ do pure $ do
syn <- maybe1 fn getContents readFile <&> parseTop <&> fromRight mempty 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 | (ListVal (Key "member" [LitStrVal s]) ) <- syn
] & catMaybes ] & catMaybes
gk <- Symm.generateGroupKey @HBS2Basic Nothing members gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
print $ pretty (AsGroupKeyFile gk) print $ pretty (AsGroupKeyFile gk)
pGroupKeySymmDump = do pGroupKeySymmDump = do
fn <- optional $ strArgument ( metavar "FILE" <> help "group key file" ) fn <- optional $ strArgument ( metavar "FILE" <> help "group key file" )
pure $ do pure $ do
gk <- ( maybe1 fn LBS.getContents LBS.readFile 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 print $ pretty gk
@ -695,7 +695,7 @@ main = join . customExecParser (prefs showHelpOnError) $
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file" creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
gk <- ( LBS.readFile fn 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 ] 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 syn <- readFile dsl <&> parseTop <&> fromRight mempty
-- FIXME: fix-code-dup-members -- 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 | (ListVal (Key "member" [LitStrVal s]) ) <- syn
] & catMaybes ] & catMaybes
debug $ vcat (fmap (pretty.AsBase58) members) debug $ vcat (fmap (pretty.AsBase58) members)
gkNew <- Symm.generateGroupKey @HBS2Basic (Just gsec) members gkNew <- Symm.generateGroupKey @'HBS2Basic (Just gsec) members
print $ pretty (AsGroupKeyFile gkNew) print $ pretty (AsGroupKeyFile gkNew)
pHash = do pHash = do
@ -758,7 +758,7 @@ main = join . customExecParser (prefs showHelpOnError) $
pRefLogGet = do pRefLogGet = do
o <- common o <- common
reflogs <- strArgument ( metavar "REFLOG" ) 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") ) pAnyRef = hsubparser ( command "get" (info pAnyRefGet (progDesc "get anyref value") )
@ -768,7 +768,7 @@ main = join . customExecParser (prefs showHelpOnError) $
pAnyRefGet = do pAnyRefGet = do
o <- common o <- common
anyref <- strArgument ( metavar "ANYREF" ) anyref <- strArgument ( metavar "ANYREF" )
pure $ withStore o (runAnyRefGet @HBS2Basic anyref) pure $ withStore o (runAnyRefGet @'HBS2Basic anyref)
pAnyRefSet = do pAnyRefSet = do
o <- common o <- common
@ -776,7 +776,7 @@ main = join . customExecParser (prefs showHelpOnError) $
val <- strArgument ( metavar "HASHREF" ) val <- strArgument ( metavar "HASHREF" )
pure $ do pure $ do
hr <- pure (fromStringMay val) `orDie` "bad HASHREF" hr <- pure (fromStringMay val) `orDie` "bad HASHREF"
withStore o (runAnyRefSet @HBS2Basic anyref hr) withStore o (runAnyRefSet @'HBS2Basic anyref hr)
pFsck = do pFsck = do
o <- common o <- common
@ -871,7 +871,7 @@ main = join . customExecParser (prefs showHelpOnError) $
ref <- pure (fromStringMay hash) `orDie` "invalid HASHREF" 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) mh <- putBlock sto (serialise refval)
@ -927,9 +927,9 @@ main = join . customExecParser (prefs showHelpOnError) $
fn <- optional $ strArgument ( metavar "SIGIL-FILE" ) fn <- optional $ strArgument ( metavar "SIGIL-FILE" )
pure $ do pure $ do
handle <- maybe1 fn (pure stdin) (flip openFile ReadMode) 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" `orDie` "parse sigil failed"
(_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
`orDie` "signature check failed" `orDie` "signature check failed"
print $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd])) 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") pk <- argument ppk (metavar "PUBKEY")
pure $ do pure $ do
sc <- BS.readFile krf sc <- BS.readFile krf
creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file" creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
sigil <- pure (makeSigilFromCredentials @L4Proto creds pk txt href) sigil <- pure (makeSigilFromCredentials @'HBS2Basic creds pk txt href)
`orDie` "public key not found in credentials file" `orDie` "public key not found in credentials file"
print $ pretty (AsBase58 sigil) print $ pretty (AsBase58 sigil)
@ -950,7 +950,7 @@ main = join . customExecParser (prefs showHelpOnError) $
phref = maybeReader fromStringMay phref = maybeReader fromStringMay
pPubKey = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic)) pPubKey = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))