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

group-keys / repository-encryption to test

This commit is contained in:
Dmitry Zuikov 2023-10-12 09:58:13 +03:00
parent 155765038e
commit c829a6d37c
36 changed files with 1394 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.fixme/log
View File

@ -1,2 +0,0 @@
fixme-del "3PJf47D9oE"

19
docs/devlog.md
View File

@ -1,3 +1,22 @@
## 2023-10-11
запостили аннотацию с ключами.
теперь пробуем её процессировать.
и вот этот волнующий момент
... тестируем, как работает удаление ключа.
- не работает пока что (почему?)
... и еще раз тестируем удаление/добавление ключей
## 2023-10-10
Начинацию операем.
Шаг 1. Выяснить, что нам вообще надо добавить нового автора
## 2023-10-08
Конечно, грустно, что девлог превратился в черти-что.

29
docs/todo/git-encryption.planb Normal file
View File

@ -0,0 +1,29 @@
;; Plan-B file
;; исходный файл гипотетической утилиты для планирования
;; когда я её сделаю? ну, после шифрования, наверное.
;; пока будем тут планировать
;; из этой штуки можно будет и TODO генерировать для fixme
[ task keyinfo
]
[ plan
-> git-hbs2-tools-key-command
-> hbs2-config-parse
-> key-info
-> key-info-test
-> key-data
-> key-metadata
-> inject-key-metadata
-> handle-key-metadata
-> encrypt-git-log
-> decrypt-git-log
-> git-encryption-a1
]

18
docs/todo/hbs2-git-private-repoes.txt
View File

@ -45,5 +45,23 @@ TODO: git-group-key
hbs2-git не будет знать, какой ключ использовать.
TODO: support-metadata-in-git-log-tree
Помещать метаданные в меркл-дерево журналов,
при первом прогоне для каждой новой транзакции
сначала обрабатывать метаданные, если они не обработаны,
вторым проходом обрабатывать уже сами транзы.
TODO: tools:generate-group-key-for-ref
Добавить функцию генерации/перегенерации группового
ключа по KeyInfo.
1. Ключ отсутствует
2. Ключ присутствует, KeyInfo expired
3. Ключ присутствует, KeyInfo не expired
TODO: tools:list-group-keys
Выводить имеющиеся ключи/шифрованные ссылки

1
flake.nix
View File

@ -71,6 +71,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
shellExtBuildInputs = {pkgs}: with pkgs; [
haskellPackages.haskell-language-server
haskellPackages.cbor-tool
haskellPackages.htags
pkg-config
inputs.hspup.packages.${pkgs.system}.default
inputs.fixme.packages.${pkgs.system}.default

24
hbs2-core/lib/HBS2/Actors/Peer/Types.hs
View File

@ -25,19 +25,19 @@ instance {-# OVERLAPPABLE #-}
-- instance HasConf m => HasConf (ResponseM e m)
instance (IsKey HbSync) => Storage AnyStorage HbSync ByteString IO where
putBlock (AnyStorage s) = putBlock s
enqueueBlock (AnyStorage s) = enqueueBlock s
getBlock (AnyStorage s) = getBlock s
getChunk (AnyStorage s) = getChunk s
hasBlock (AnyStorage s) = hasBlock s
updateRef (AnyStorage s) = updateRef s
getRef (AnyStorage s) = getRef s
delBlock (AnyStorage s) = delBlock s
delRef (AnyStorage s) = delRef s
instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m where
putBlock (AnyStorage s) = liftIO . putBlock s
enqueueBlock (AnyStorage s) = liftIO . enqueueBlock s
getBlock (AnyStorage s) = liftIO . getBlock s
getChunk (AnyStorage s) h a b = liftIO $ getChunk s h a b
hasBlock (AnyStorage s) = liftIO . hasBlock s
updateRef (AnyStorage s) r v = liftIO $ updateRef s r v
getRef (AnyStorage s) = liftIO . getRef s
delBlock (AnyStorage s) = liftIO . delBlock s
delRef (AnyStorage s) = liftIO . delRef s
data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
) => AnyStorage zu
data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
) => AnyStorage zu
class HasStorage m where
getStorage :: m AnyStorage

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

@ -1,8 +1,13 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language TemplateHaskell #-}
{-# Language UndecidableInstances #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language ConstraintKinds #-}
module HBS2.Net.Auth.GroupKeySymm where
module HBS2.Net.Auth.GroupKeySymm
( module HBS2.Net.Auth.GroupKeySymm
, module HBS2.Net.Proto.Types
, KeyringEntry(..), krPk, krSk
) where
import HBS2.Prelude.Plated
import HBS2.Base58
@ -17,9 +22,6 @@ import HBS2.Storage.Operations.Class
import HBS2.Storage.Operations.ByteString
import HBS2.Storage(Storage(..))
import HBS2.System.Logger.Simple
import Data.ByteArray.Hash qualified as BA
import Codec.Serialise
import Crypto.KDF.HKDF qualified as HKDF
@ -37,10 +39,9 @@ import Data.ByteString.Char8 qualified as B8
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.Function
import Data.Functor
import Data.List qualified as List
import Data.List.Split (chunksOf)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Maybe
import Data.Word (Word64)
import Data.ByteArray()
@ -57,12 +58,25 @@ import Data.Bits (xor)
type GroupSecretAsymm = Key
-- NOTE: breaking-change
-- NOTE: not-a-monoid
-- это моноид, но опасный, потому, что секретные ключи у двух разных
-- групповых ключей могут быть разными, и если
-- просто объединить два словаря - какой-то секретный
-- ключ может быть потерян. а что делать-то, с другой стороны?
data instance GroupKey 'Symm s =
GroupKeySymm
{ recipients :: [(PubKey 'Encrypt s, EncryptedBox GroupSecretAsymm)]
{ recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecretAsymm)
}
deriving stock (Generic)
instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where
mempty = GroupKeySymm mempty
instance ForGroupKeySymm s => Semigroup (GroupKey 'Symm s) where
(<>) (GroupKeySymm a) (GroupKeySymm b) = GroupKeySymm (a <> b)
instance Serialise Key
instance Serialise SK.Nonce
@ -73,8 +87,9 @@ data instance ToEncrypt 'Symm s LBS.ByteString =
, toEncryptNonce :: BS.ByteString
, toEncryptData :: Stream (Of LBS.ByteString) IO ()
, toEncryptGroupKey :: GroupKey 'Symm s
, toEncryptMeta :: AnnMetaData
}
deriving (Generic)
type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
, PubKey 'Encrypt s ~ AK.PublicKey
@ -88,11 +103,16 @@ type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s)
instance Pretty (AsBase58 (PubKey 'Encrypt s)) => Pretty (GroupKey 'Symm s) where
pretty g = vcat (fmap prettyEntry (recipients g))
pretty g = vcat (fmap prettyEntry (HashMap.toList (recipients g)))
where
prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk))
instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
fromStringMay s = runIdentity $ runMaybeT do
bs <- toMPlus $ fromBase58 $ B8.pack s
toMPlus $ deserialiseOrFail @(GroupKey 'Symm s) (LBS.fromStrict bs)
instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where
pretty (AsGroupKeyFile pc) = "# hbs2 symmetric group key file"
<> line <> co
@ -109,10 +129,10 @@ parseGroupKey :: forall s . (ForGroupKeySymm s, Serialise (GroupKey 'Symm s))
parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 (LBS8.toStrict bs)
instance ( Serialise (GroupKey 'Asymm s)
instance ( Serialise (GroupKey 'Symm s)
)
=> Pretty (AsBase58 (GroupKey 'Asymm s)) where
=> Pretty (AsBase58 (GroupKey 'Symm s)) where
pretty (AsBase58 c) =
pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
@ -121,11 +141,9 @@ generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m)
-> [PubKey 'Encrypt s]
-> m (GroupKey 'Symm s)
generateGroupKey mbk pks' = GroupKeySymm <$> create
generateGroupKey mbk pks = GroupKeySymm <$> create
where
pks = List.sort (List.nub pks')
create = do
create = HashMap.fromList <$> do
sk <- maybe1 mbk (liftIO SK.newKey) pure
forM pks $ \pk -> do
box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
@ -138,7 +156,7 @@ lookupGroupKey :: ForGroupKeySymm s
-> Maybe GroupSecretAsymm
lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
(EncryptedBox bs) <- MaybeT $ pure $ List.lookup pk (recipients gk)
(EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk)
-- error "FOUND SHIT!"
gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs
-- error $ "DECRYPTED SHIT!"
@ -230,7 +248,7 @@ instance ( MonadIO m
tree <- maybe (throwError StorageError) pure root
let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree
let ann = MTreeAnn (toEncryptMeta source) (EncryptGroupNaClSymm (fromHashRef gkh) nonceS) tree
putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure
@ -243,31 +261,20 @@ instance ( MonadIO m
, sch ~ HBS2Basic
) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
data instance TreeKey (ToDecrypt 'Symm sch ByteString) = ToDecryptBS [KeyringEntry sch] (Hash HbSync)
data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
ToDecryptBS [KeyringEntry sch] (Hash HbSync)
| ToDecryptBS2 (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTree [HashRef])
type instance ToBlockR (ToDecrypt 'Symm sch ByteString) = ByteString
type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString
readFromMerkle sto (ToDecryptBS ke h) = do
readFromMerkle sto decrypt = do
let keys = [ (view krPk x, view krSk x) | x <- ke ]
bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure
let what = tryDetect h bs
let tree' = case what of
MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n))
_ -> Nothing
(tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure
gkbs <- readFromMerkle sto (SimpleKey gkh)
gk <- either (const $ throwError GroupKeyNotFound) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs)
(keys, gk, nonceS, tree) <- decryptDataFrom decrypt
let gksec' = [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay
gksec <- maybe1 gksec' (throwError GroupKeyNotFound) pure
gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode gksec)
let key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
@ -282,6 +289,7 @@ instance ( MonadIO m
blk <- getBlock sto (fromHashRef h) >>= maybe (throwError MissedBlockError) pure
let nonceI = nonceFrom (nonce0, i)
let unboxed = SK.secretboxOpen key0 nonceI (LBS.toStrict blk)
maybe1 unboxed (throwError DecryptionError) (pure . LBS.fromStrict)
@ -290,3 +298,28 @@ instance ( MonadIO m
pure $ mconcat ss
where
decryptDataFrom = \case
ToDecryptBS2 gk nonce ke tree -> do
let keys = [ (view krPk x, view krSk x) | x <- ke ]
pure (keys, gk, nonce, tree)
ToDecryptBS ke h -> do
let keys = [ (view krPk x, view krSk x) | x <- ke ]
bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure
let what = tryDetect h bs
let tree' = case what of
MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm g n}) -> Just (_mtaTree ann, (g,n))
_ -> Nothing
(tree, (gkh,nonceS)) <- maybe1 tree' (throwError UnsupportedFormat) pure
gkbs <- readFromMerkle sto (SimpleKey gkh)
gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs)
pure (keys, gk, nonceS, tree)

2
hbs2-core/lib/HBS2/Net/Proto/RefLog.hs
View File

@ -22,7 +22,7 @@ import Data.ByteString (ByteString)
import Type.Reflection (someTypeRep)
import Lens.Micro.Platform
newtype RefLogKey s = RefLogKey (PubKey 'Sign s)
newtype RefLogKey s = RefLogKey { fromRefLogKey :: PubKey 'Sign s }
deriving stock instance IsRefPubKey s => Eq (RefLogKey s)

24
hbs2-core/lib/HBS2/Prelude.hs
View File

@ -1,3 +1,4 @@
{-# Language FunctionalDependencies #-}
module HBS2.Prelude
( module Data.String
, module Safe
@ -6,6 +7,7 @@ module HBS2.Prelude
, void, guard, when, unless
, maybe1
, eitherToMaybe
, ToMPlus(..)
, Hashable
, lift
, AsFileName(..)
@ -16,6 +18,7 @@ module HBS2.Prelude
, ToByteString(..)
, FromByteString(..)
, Text.Text
, (&), (<&>)
) where
import Data.Typeable as X
@ -25,10 +28,13 @@ import Data.ByteString (ByteString)
import Data.String (IsString(..))
import Safe
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (void,guard,when,unless)
import Control.Monad (guard,when,unless,MonadPlus(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Data.Kind
import Data.Function
import Data.Functor
import Data.Char qualified as Char
import Data.Text qualified as Text
import Data.Hashable
@ -62,3 +68,19 @@ class ToByteString a where
class FromByteString a where
fromByteString :: ByteString -> Maybe a
class MonadPlus m => ToMPlus m a where
type family ToMPlusResult a :: Type
toMPlus :: a -> m (ToMPlusResult a)
instance Monad m => ToMPlus (MaybeT m) (Maybe a) where
type instance ToMPlusResult (Maybe a) = a
toMPlus Nothing = mzero
toMPlus (Just a) = MaybeT (pure (Just a))
instance Monad m => ToMPlus (MaybeT m) (Either x a) where
type instance ToMPlusResult (Either x a) = a
toMPlus (Left{}) = mzero
toMPlus (Right x) = MaybeT $ pure (Just x)

18
hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs
View File

@ -24,6 +24,8 @@ import Control.Monad.Except
import Data.Bifunctor
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
-- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
-- importimport Data.List.Split (chunksOf)
instance (MonadIO m, h ~ HbSync, Storage s h ByteString m) => MerkleWriter ByteString h s m where
@ -69,3 +71,19 @@ instance ( MonadIO m
pure $ mconcat pieces
readChunkedBS :: (Integral a, Monad m)
=> ByteString
-> a
-> S.Stream (S.Of ByteString) m ()
readChunkedBS bs size = foo bs
where
foo =
fix $ \loop leftover -> do
let (chunk, rest) = LBS.splitAt (fromIntegral size) leftover
unless (LBS.null chunk) do
S.yield chunk
loop rest

2
hbs2-core/lib/HBS2/Storage/Operations/Class.hs
View File

@ -13,7 +13,7 @@ data OperationError =
| DecryptionError
| MissedBlockError
| UnsupportedFormat
| GroupKeyNotFound
| GroupKeyNotFound Int
deriving (Generic,Show,Data,Typeable)
-- instance Exception OperationError

18
hbs2-git/examples/config/encrypted-ref Normal file
View File

@ -0,0 +1,18 @@
rpc unix "/tmp/hbs2-rpc.socket"
keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key"
keyring "/home/dmz/w/hbs2/test1.key"
keyring "/home/dmz/w/hbs2/test2.key"
keyring "/home/dmz/w/hbs2/test3.key"
keyring "/home/dmz/w/hbs2/test4.key"
keyring "/home/dmz/w/hbs2/test5.key"
[ encrypted "EDRuSaFmWbCnyUNtFbgCtqfiCrYPJvnY9pZB81AbSTbr"
(ttl 86400)
(owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
(member "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
(member "GcTjPEDSTCKNKnwPZWBjudeTqSie2fvYfsoSAzUKTRZ5")
]

30
hbs2-git/examples/config/encrypted-ref-2 Normal file
View File

@ -0,0 +1,30 @@
rpc unix "/tmp/hbs2-rpc.socket"
branch "master"
branch "hbs2-git"
keyring "/home/dmz/dmz-data/hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP.key"
keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key"
keyring "/home/dmz/w/hbs2/k5.key"
;;keyring "/home/dmz/w/hbs2/test1.key"
;;keyring "/home/dmz/w/hbs2/test2.key"
;;keyring "/home/dmz/w/hbs2/test6.key"
;; keyring "/home/dmz/w/hbs2/test3.key"
decrypt "/home/dmz/w/hbs2/au11.key"
decrypt "/home/dmz/w/hbs2/owner.key"
decrypt "/home/dmz/w/hbs2/k5.key"
[ encrypted "HFKuPTyaQLLmfgfVveu5GA4spt4c6oQBMUo1aeQ4abXG"
(ttl 86400)
(owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
(member "H9miZgHYg84wZM8Hu93t7iLHcKnZytAEgcB26LGbLTz4")
(member "2jsaezeu8iCRYBqMVBauCxnkHXvP3CkEFLeVxE8bRfvH")
(member "FNGD1oNh9AVXw1v7ZFpC5V2P2GGYRoUwnP6qwTw9JGpn")
(member "J2FWG3uib7TpZsu1k8sz8cekC3VH1ggNBhZKJxtUce4Q")
(member "E9WGzRzmD5G5SHbz9u7n3WKCz1eaVNPvT5f1NEKUQ6FU")
(keyring "/home/dmz/w/hbs2/owner.key")
]

49
hbs2-git/git-hbs2/GitRemoteMain.hs
View File

@ -40,6 +40,7 @@ import Text.InterpolatedString.Perl6 (qc)
import UnliftIO.IO as UIO
import Control.Monad.Catch
import Control.Monad.Trans.Resource
import Lens.Micro.Platform
send :: MonadIO m => BS.ByteString -> m ()
@ -74,24 +75,48 @@ capabilities :: BS.ByteString
capabilities = BS.unlines ["push","fetch"]
getGlobalOptionFromURL :: HasGlobalOptions m => [String] -> m ()
getGlobalOptionFromURL args = do
case args of
[_, ss] -> do
let (_, suff) = Text.breakOn "?" (Text.pack ss)
& over _2 (Text.dropWhile (== '?'))
& over _2 (Text.splitOn "&")
& over _2 (fmap (over _2 (Text.dropWhile (=='=')) . Text.break (== '=')))
& over _2 (filter (\(k,_) -> k /= ""))
forM_ suff $ \(k,v) -> do
addGlobalOption (Text.unpack k) (Text.unpack v)
_ -> pure ()
loop :: forall m . ( MonadIO m
, MonadCatch m
, MonadUnliftIO m
, MonadMask m
, HasProgress (RunWithConfig (GitRemoteApp m))
, HasStorage (RunWithConfig (GitRemoteApp m))
, HasRPC (RunWithConfig (GitRemoteApp m))
) => [String] -> GitRemoteApp m ()
, HasProgress m
, HasConf m
, HasStorage m
, HasRPC m
, HasRefCredentials m
, HasEncryptionKeys m
, HasGlobalOptions m
) => [String] -> m ()
loop args = do
trace $ "args:" <+> pretty args
let ref' = case args of
[_, s] -> Text.stripPrefix "hbs2://" (Text.pack s) <&> fromString @RepoRef . Text.unpack
_ -> Nothing
ref <- case args of
[_, ss] -> do
let (s, _) = Text.breakOn "?" (Text.pack ss)
ref <- pure ref' `orDie` ("invalid reference: " <> show args)
let r = Text.stripPrefix "hbs2://" s <&> fromString @RepoRef . Text.unpack
pure r `orDie` [qc|bad reference {args}||]
_ -> do
die [qc|bad reference: {args}|]
trace $ "ref:" <+> pretty ref
@ -230,10 +255,16 @@ main = do
runWithRPC $ \rpc -> do
env <- RemoteEnv <$> liftIO (newTVarIO mempty)
<*> liftIO (newTVarIO mempty)
<*> liftIO (newTVarIO mempty)
<*> pure rpc
runRemoteM env do
loop args
runWithConfig syn $ do
getGlobalOptionFromURL args
loadCredentials mempty
loadKeys
loop args
shutUp

54
hbs2-git/git-hbs2/GitRemotePush.hs
View File

@ -44,6 +44,11 @@ newtype RunWithConfig m a =
runWithConfig :: MonadIO m => [Syntax C] -> RunWithConfig m a -> m a
runWithConfig conf m = runReaderT (fromWithConf m) conf
instance (Monad m, HasGlobalOptions m) => HasGlobalOptions (RunWithConfig m) where
addGlobalOption k v = lift $ addGlobalOption k v
getGlobalOption k = lift $ getGlobalOption k
instance (Monad m, HasStorage m) => HasStorage (RunWithConfig m) where
getStorage = lift getStorage
@ -57,44 +62,43 @@ instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
getCredentials = lift . getCredentials
setCredentials r c = lift $ setCredentials r c
instance MonadIO m => HasEncryptionKeys (RunWithConfig (GitRemoteApp m)) where
addEncryptionKey = lift . addEncryptionKey
findEncryptionKey = lift . findEncryptionKey
enumEncryptionKeys = lift enumEncryptionKeys
push :: forall m . ( MonadIO m
, MonadCatch m
, HasProgress (RunWithConfig (GitRemoteApp m))
, MonadMask (RunWithConfig (GitRemoteApp m))
, HasStorage (RunWithConfig (GitRemoteApp m))
, HasConf m
, HasRefCredentials m
, HasEncryptionKeys m
, HasGlobalOptions m
, HasStorage m
, HasRPC m
, MonadUnliftIO m
, MonadMask m
)
=> RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef)
=> RepoRef -> [Maybe GitRef] -> m (Maybe GitRef)
push remote what@[Just bFrom , Just br] = do
(_, syn) <- Config.configInit
dbPath <- makeDbPath remote
db <- dbEnv dbPath
runWithConfig syn do
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
loadCredentials mempty
trace $ "PUSH PARAMS" <+> pretty what
gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|]
_ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh
importRefLogNew False remote
pure (Just br)
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
trace $ "PUSH PARAMS" <+> pretty what
gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|]
_ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh
importRefLogNew False remote
pure (Just br)
push remote [Nothing, Just br] = do
(_, syn) <- Config.configInit
runWithConfig syn do
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
loadCredentials mempty
trace $ "deleting remote reference" <+> pretty br
exportRefDeleted () remote br
importRefLogNew False remote
pure (Just br)
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
trace $ "deleting remote reference" <+> pretty br
exportRefDeleted () remote br
importRefLogNew False remote
pure (Just br)
push r w = do
warn $ "ignoring weird push" <+> pretty w <+> pretty r

25
hbs2-git/git-hbs2/GitRemoteTypes.hs
View File

@ -4,7 +4,8 @@ module GitRemoteTypes where
import HBS2.Prelude
import HBS2.OrDie
import HBS2.Net.Auth.Credentials (PeerCredentials)
import HBS2.Net.Proto
import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Definition()
import HBS2.Peer.RPC.Client.StorageClient
@ -20,6 +21,8 @@ import Control.Monad.Trans.Resource
data RemoteEnv =
RemoteEnv
{ _reCreds :: TVar (HashMap RepoRef (PeerCredentials Schema))
, _reKeys :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema))
, _reOpts :: TVar (HashMap String String)
, _reRpc :: RPCEndpoints
}
@ -48,6 +51,16 @@ instance Monad m => HasRPC (GitRemoteApp m) where
runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a
runRemoteM env m = runReaderT (fromRemoteApp m) env
instance MonadIO m => HasGlobalOptions (GitRemoteApp m) where
addGlobalOption k v =
asks (view reOpts ) >>= \t -> liftIO $ atomically $
modifyTVar' t (HashMap.insert k v)
getGlobalOption k = do
hm <- asks (view reOpts) >>= liftIO . readTVarIO
pure (HashMap.lookup k hm)
instance MonadIO m => HasRefCredentials (GitRemoteApp m) where
setCredentials ref cred = do
@ -56,8 +69,16 @@ instance MonadIO m => HasRefCredentials (GitRemoteApp m) where
getCredentials ref = do
hm <- asks (view reCreds) >>= liftIO . readTVarIO
pure (HashMap.lookup ref hm) `orDie` "keyring not set"
pure (HashMap.lookup ref hm) `orDie` "keyring not set (3)"
instance MonadIO m => HasEncryptionKeys (GitRemoteApp m) where
addEncryptionKey ke = do
asks (view reKeys) >>= \t -> liftIO $ atomically do
modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke))
findEncryptionKey puk = (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk
enumEncryptionKeys = do
them <- (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList
pure $ [KeyringEntry k s Nothing | (k,s) <- them ]

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

@ -1,13 +1,17 @@
module Main where
import HBS2.Prelude
import HBS2.OrDie
import HBS2Git.App
import HBS2Git.Export
import HBS2Git.ListRefs
import HBS2Git.KeysCommand
import HBS2.Net.Proto.Definition()
import RunShow
import Data.Functor
import Options.Applicative as O
import Control.Monad
@ -24,6 +28,7 @@ main = join . customExecParser (prefs showHelpOnError) $
<> command "list-refs" (info pListRefs (progDesc "list refs"))
<> command "show" (info pShow (progDesc "show various types of objects"))
<> command "tools" (info pTools (progDesc "misc tools"))
<> command "key" (info pKeys (progDesc "manage keys"))
)
pExport = do
@ -57,3 +62,27 @@ main = join . customExecParser (prefs showHelpOnError) $
ref <- strArgument (metavar "HASH-REF")
pure $ runApp WithLog (runToolsGetRefs ref)
pKeys = hsubparser ( command "list" (info pKeysList (progDesc "list keys for refs"))
<> command "refs" (info pKeyRefsList (progDesc "list encrypted refs"))
<> command "update" (info pKeyUpdate (progDesc "update key for the ref"))
)
pKeyUpdate = do
ref <- strArgument (metavar "REF-KEY")
pure $ do
rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY"
runApp WithLog (runKeysUpdate rk)
pKeyRefsList = do
pure $ do
runApp WithLog runKeyRefsList
pKeysList = do
ref <- strArgument (metavar "REF-KEY")
pure $ do
rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY"
runApp WithLog (runKeysList rk)

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

@ -70,6 +70,7 @@ common shared-properties
, exceptions
, filelock
, filepath
, filepattern
, hashable
, http-conduit
, interpolatedstring-perl6
@ -102,15 +103,21 @@ library
exposed-modules:
HBS2.Git.Types
HBS2.Git.Local
HBS2.Git.Local.CLI
HBS2Git.Alerts
HBS2Git.Annotations
HBS2Git.App
HBS2Git.KeysMetaData
HBS2Git.Config
HBS2Git.Evolve
HBS2Git.Export
HBS2Git.Encryption
HBS2Git.Encryption.KeyInfo
HBS2Git.GitRepoLog
HBS2Git.Import
HBS2Git.KeysCommand
HBS2Git.ListRefs
HBS2.Git.Local
HBS2.Git.Local.CLI
HBS2Git.PrettyStuff
HBS2Git.State
HBS2Git.Types

2
hbs2-git/hie.yaml Normal file
View File

@ -0,0 +1,2 @@
cradle:
cabal:

2
hbs2-git/lib/HBS2/Git/Types.hs
View File

@ -128,5 +128,7 @@ shutUp = do
setLoggingOff @ERROR
setLoggingOff @NOTICE
setLoggingOff @TRACE
setLoggingOff @INFO
setLoggingOff @WARN

9
hbs2-git/lib/HBS2Git/Alerts.hs Normal file
View File

@ -0,0 +1,9 @@
module HBS2Git.Alerts where
import HBS2.Prelude
import Text.InterpolatedString.Perl6 (qc)
noKeyInfoMsg :: forall a . Pretty a => a -> String
noKeyInfoMsg repo =
[qc|*** No KeyInfo found, maybe malformed 'encryption' section for {pretty repo} in config|]

24
hbs2-git/lib/HBS2Git/Annotations.hs Normal file
View File

@ -0,0 +1,24 @@
module HBS2Git.Annotations where
import HBS2.Prelude.Plated
import HBS2.Data.Types.Refs
import HBS2Git.Encryption
import Codec.Serialise
data Annotation =
GK1 HashRef (GroupKey 'Symm HBS2Basic)
deriving (Generic)
data Annotations =
NoAnnotations
| SmallAnnotations [Annotation]
deriving (Generic)
instance Serialise Annotation
instance Serialise Annotations

322
hbs2-git/lib/HBS2Git/App.hs
View File

@ -5,10 +5,11 @@ module HBS2Git.App
( module HBS2Git.App
, module HBS2Git.Types
, HasStorage(..)
, HasConf(..)
)
where
import HBS2.Prelude
import HBS2.Prelude.Plated
import HBS2.Actors.Peer.Types
import HBS2.Data.Types.Refs
import HBS2.Base58
@ -16,7 +17,8 @@ import HBS2.OrDie
import HBS2.Hash
import HBS2.Clock
import HBS2.Storage
import HBS2.Storage.Operations.ByteString
import HBS2.Storage.Operations.ByteString as OP
import HBS2.Net.Auth.GroupKeySymm qualified as Symm
import HBS2.System.Logger.Simple
import HBS2.Merkle
import HBS2.Git.Types
@ -32,8 +34,12 @@ import HBS2.Peer.RPC.API.RefLog
import HBS2Git.Types
import HBS2Git.Config as Config
import HBS2Git.State
import HBS2Git.KeysMetaData
import HBS2Git.Encryption
import HBS2Git.Evolve
import HBS2Git.PrettyStuff
import HBS2Git.Alerts
import Data.Maybe
import Control.Monad.Trans.Maybe
@ -41,7 +47,9 @@ import Data.Foldable
import Data.Either
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Control.Monad.Except (runExceptT,throwError)
-- import Control.Monad.Except (runExceptT,throwError)
import Control.Monad.Except (runExceptT)
import Control.Monad.Catch
import Crypto.Saltine.Core.Sign qualified as Sign
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.ByteString.Char8 qualified as B8
@ -50,20 +58,22 @@ import Data.Set (Set)
import Data.Set qualified as Set
import Lens.Micro.Platform
import System.Directory
import System.FilePattern.Directory
-- import System.FilePath
import System.FilePath
import System.Process.Typed
import Text.InterpolatedString.Perl6 (qc)
import Network.HTTP.Simple
import Network.HTTP.Types.Status
-- import Network.HTTP.Simple
-- import Network.HTTP.Types.Status
import Control.Concurrent.STM (flushTQueue)
import Codec.Serialise
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.List qualified as List
import Data.Text qualified as Text
-- import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Data.Cache qualified as Cache
-- import System.IO.Unsafe (unsafePerformIO)
-- import Data.Cache qualified as Cache
-- import Control.Concurrent.Async
import System.Environment
@ -113,6 +123,16 @@ infoPrefix = toStderr
data WithLog = NoLog | WithLog
instance MonadIO m => HasGlobalOptions (App m) where
addGlobalOption k v =
asks (view appOpts ) >>= \t -> liftIO $ atomically $
modifyTVar' t (HashMap.insert k v)
getGlobalOption k = do
hm <- asks (view appOpts) >>= liftIO . readTVarIO
pure (HashMap.lookup k hm)
instance MonadIO m => HasRefCredentials (App m) where
setCredentials ref cred = do
asks (view appRefCred) >>= \t -> liftIO $ atomically $
@ -120,7 +140,18 @@ instance MonadIO m => HasRefCredentials (App m) where
getCredentials ref = do
hm <- asks (view appRefCred) >>= liftIO . readTVarIO
pure (HashMap.lookup ref hm) `orDie` "keyring not set"
pure (HashMap.lookup ref hm) `orDie` "keyring not set (1)"
instance MonadIO m => HasEncryptionKeys (App m) where
addEncryptionKey ke = do
asks (view appKeys) >>= \t -> liftIO $ atomically do
modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke))
findEncryptionKey puk = (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk
enumEncryptionKeys = do
them <- (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList
pure $ [KeyringEntry k s Nothing | (k,s) <- them ]
instance (Monad m, HasStorage m) => (HasStorage (ResourceT m)) where
getStorage = lift getStorage
@ -134,62 +165,6 @@ instance MonadIO m => HasRPC (App m) where
withApp :: MonadIO m => AppEnv -> App m a -> m a
withApp env m = runReaderT (fromApp m) env
{-# NOINLINE hBS2PeerCatAPI #-}
hBS2PeerCatAPI :: IORef (Maybe API)
hBS2PeerCatAPI = unsafePerformIO (newIORef Nothing)
detectHBS2PeerCatAPI :: MonadIO m => m API
detectHBS2PeerCatAPI = do
-- FIXME: hardcoded-hbs2-peer
v <- liftIO $ readIORef hBS2PeerCatAPI
case v of
Just x -> pure x
Nothing -> do
(_, o, _) <- readProcess (shell [qc|hbs2-peer poke|])
let dieMsg = "hbs2-peer is down or it's http is inactive"
let answ = parseTop (LBS.unpack o) & fromRight mempty
let po = headMay [ n | ListVal (Key "http-port:" [LitIntVal n]) <- answ ]
-- shutUp
pnum <- pure po `orDie` dieMsg
debug $ pretty "using http port" <+> pretty po
let api = [qc|http://localhost:{pnum}/cat|]
liftIO $ writeIORef hBS2PeerCatAPI (Just api)
pure api
detectHBS2PeerSizeAPI :: MonadIO m => m API
detectHBS2PeerSizeAPI = do
api <- detectHBS2PeerCatAPI
let new = Text.replace "/cat" "/size" $ Text.pack api
pure $ Text.unpack new
detectHBS2PeerPutAPI :: MonadIO m => m API
detectHBS2PeerPutAPI = do
api <- detectHBS2PeerCatAPI
let new = Text.replace "/cat" "/" $ Text.pack api
pure $ Text.unpack new
detectHBS2PeerRefLogGetAPI :: MonadIO m => m API
detectHBS2PeerRefLogGetAPI = do
api <- detectHBS2PeerCatAPI
let new = Text.replace "/cat" "/reflog" $ Text.pack api
pure $ Text.unpack new
getAppStateDir :: forall m . MonadIO m => m FilePath
getAppStateDir = liftIO $ getXdgDirectory XdgData Config.appName
runWithRPC :: forall m . MonadUnliftIO m => (RPCEndpoints -> m ()) -> m ()
runWithRPC action = do
@ -276,8 +251,10 @@ runApp l m = do
runWithRPC $ \rpc -> do
mtCred <- liftIO $ newTVarIO mempty
let env = AppEnv pwd (pwd </> ".git") syn xdgstate mtCred rpc
runReaderT (fromApp m) (set appRpc rpc env)
mtKeys <- liftIO $ newTVarIO mempty
mtOpt <- liftIO $ newTVarIO mempty
let env = AppEnv pwd (pwd </> ".git") syn xdgstate mtCred mtKeys mtOpt rpc
runReaderT (fromApp (loadKeys >> m)) (set appRpc rpc env)
debug $ vcat (fmap pretty syn)
@ -347,7 +324,11 @@ calcRank h = fromMaybe 0 <$> runMaybeT do
pure $ sum n
postRefUpdate :: ( MonadIO m
, MonadMask m
, HasStorage m
, HasConf m
, HasRefCredentials m
, HasEncryptionKeys m
, HasRPC m
, IsRefPubKey Schema
)
@ -362,7 +343,11 @@ postRefUpdate ref seqno hash = do
cred <- getCredentials ref
let pubk = view peerSignPk cred
let privk = view peerSignSk cred
let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash)
ann <- genKeysAnnotations ref
-- вот прямо сюда ОЧЕНЬ удобно вставить метаданные для GK1
let tran = SequentialRef seqno (AnnotatedHashRef ann hash)
let bs = serialise tran & LBS.toStrict
msg <- makeRefLogUpdate @HBS2L4Proto pubk privk bs
@ -373,17 +358,46 @@ postRefUpdate ref seqno hash = do
>>= either (err . viaShow) (const $ pure ())
storeObject :: (MonadIO m, HasStorage m, HasConf m)
=> ByteString -> ByteString -> m (Maybe HashRef)
storeObject = storeObjectRPC
storeObject :: ( MonadIO m
, MonadMask m
, HasStorage m
, HasConf m
, HasRefCredentials m
, HasEncryptionKeys m
)
=> RepoRef
-> ByteString
-> ByteString
-> m (Maybe HashRef)
storeObject repo meta bs = do
encrypted <- isRefEncrypted (fromRefLogKey repo)
info $ "encrypted" <+> pretty repo <> colon <+> if encrypted then "yes" else "no"
storeObjectRPC encrypted repo meta bs
storeObjectRPC :: (MonadIO m, HasStorage m)
=> ByteString
data WriteOp = WritePlain | WriteEncrypted B8.ByteString
storeObjectRPC :: ( MonadIO m
, MonadMask m
, HasStorage m
, HasConf m
, HasRefCredentials m
, HasEncryptionKeys m
)
=> Bool
-> RepoRef
-> ByteString
-> ByteString
-> m (Maybe HashRef)
storeObjectRPC meta bs = do
storeObjectRPC False repo meta bs = do
sto <- getStorage
db <- makeDbPath repo >>= dbEnv
runMaybeT do
h <- liftIO $ writeAsMerkle sto bs
let txt = LBS.unpack meta & Text.pack
blk <- MaybeT $ liftIO $ getBlock sto h
@ -392,15 +406,58 @@ storeObjectRPC meta bs = do
mtree <- MaybeT $ deserialiseOrFail @(MTree [HashRef]) blk
& either (const $ pure Nothing) (pure . Just)
-- TODO: upadte-metadata-right-here
let ann = serialise (MTreeAnn (ShortMetadata txt) NullEncryption mtree)
MaybeT $ liftIO $ putBlock sto ann <&> fmap HashRef
makeDbPath :: MonadIO m => RepoRef -> m FilePath
makeDbPath h = do
state <- getAppStateDir
liftIO $ createDirectoryIfMissing True state
pure $ state </> show (pretty (AsBase58 h))
storeObjectRPC True repo meta bs = do
sto <- getStorage
db <- makeDbPath repo >>= dbEnv
runMaybeT do
let txt = LBS.unpack meta & Text.pack
ki <- lift $ getKeyInfo (fromRefLogKey repo) >>= maybe noKeyInfo pure
gkh0 <- withDB db $ stateGetLocalKey ki >>= maybe noKeyFound pure
gk0 <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh0)))
>>= either (const $ noKeyFound) (pure . deserialiseOrFail @(GroupKey 'Symm HBS2Basic))
>>= either (const $ noKeyFound) pure
let pk = keyInfoOwner ki
sk <- lift (findEncryptionKey pk) >>= maybe noKeyFound pure
gks <- maybe noKeyFound pure (Symm.lookupGroupKey sk pk gk0)
let nonce = hashObject @HbSync bs & serialise
& LBS.drop 2
& LBS.toStrict
let bsStream = readChunkedBS bs defBlockSize
let source = ToEncryptSymmBS gks nonce bsStream gk0 (ShortMetadata txt)
h <- runExceptT (writeAsMerkle sto source) >>= either (const cantWriteMerkle) pure
pure (HashRef h)
where
cantWriteMerkle :: forall a m . MonadIO m => m a
cantWriteMerkle = die "Can't write encrypted merkle tree"
noKeyFound :: forall a m . MonadIO m => m a
noKeyFound = do
liftIO $ hPutDoc stderr (red $ "No group key found for repo" <+> pretty repo <> line)
die "*** fatal"
noKeyInfo = do
liftIO $ hPutDoc stderr (red $ pretty (noKeyInfoMsg repo) <> line)
die "*** fatal"
loadCredentials :: ( MonadIO m
, HasConf m
@ -408,20 +465,23 @@ loadCredentials :: ( MonadIO m
) => [FilePath] -> m ()
loadCredentials fp = do
trace $ "loadCredentials" <+> pretty fp
debug $ "loadCredentials" <+> pretty fp
krOpt' <- cfgValue @KeyRingFiles @(Set FilePath) <&> Set.toList
let krOpt = List.nub $ fp <> krOpt'
when (null krOpt) do
die "keyring not set"
void $ runMaybeT do
for_ krOpt $ \fn -> do
(puk, cred) <- loadKeyring fn
trace $ "got creds for" <+> pretty (AsBase58 puk)
setCredentials (RefLogKey puk) cred
pure ()
when (null krOpt) do
debug "keyring not set (2)"
mzero
for_ krOpt $ \fn -> do
(puk, cred) <- loadKeyring fn
trace $ "got creds for" <+> pretty (AsBase58 puk)
lift $ setCredentials (RefLogKey puk) cred
pure ()
loadCredentials' ::
( MonadIO m
@ -429,16 +489,96 @@ loadCredentials' ::
)
=> FilePath -> m Sign.PublicKey
loadCredentials' fn = do
(puk, cred) <- loadKeyring fn
(puk, cred) <- runMaybeT (loadKeyring fn) `orDie` [qc|Can't load credentials {fn}|]
trace $ "got creds for" <+> pretty (AsBase58 puk)
setCredentials (RefLogKey puk) cred
pure puk
loadKeyring :: (MonadIO m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema)
loadKeyring :: (MonadIO m, MonadPlus m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema)
loadKeyring fn = do
krData <- liftIO $ B8.readFile fn
cred <- pure (parseCredentials @Schema (AsCredFile krData)) `orDie` "bad keyring file"
let puk = view peerSignPk cred
pure (puk, cred)
let cred' = parseCredentials @Schema (AsCredFile krData)
maybe1 cred' mzero $ \cred -> do
let puk = view peerSignPk cred
pure (puk, cred)
makeFilter :: String -> (String, [String])
makeFilter = norm . over _1 sub1 . over _2 List.singleton . go ""
where
go pref ( cn : cs ) | cn `elem` "?*" = (p0, p1 <> p2)
where
(p0, p1) = splitFileName pref
p2 = cn : cs
go pref ( '/' : cn : cs ) | cn `elem` "?*" = (pref <> ['/'], cn : cs)
go pref ( c : cs ) = go (pref <> [c]) cs
go pref [] = (pref, "")
sub1 "" = "."
sub1 x = x
norm (xs, [""]) = (p1, [p2])
where
(p1, p2) = splitFileName xs
norm x = x
loadKeys :: ( MonadIO m
, HasConf m
, HasEncryptionKeys m
, HasGlobalOptions m
) => m ()
loadKeys = do
conf <- getConf
trace $ "loadKeys"
kp <- liftIO $ lookupEnv "HBS2KEYS"
found1 <- findKeyFiles =<< liftIO (lookupEnv "HBS2KEYS")
found2 <- findKeyFiles =<< getGlobalOption "key"
found <- liftIO $ mapM canonicalizePath (found1 <> found2)
let enc = [ args | (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) <- conf ]
let owners = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
| ListVal @C (Key "owner" [LitStrVal o]) <- universeBi enc
] & catMaybes & HashSet.fromList
let members = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
| ListVal @C (Key "member" [LitStrVal o]) <- universeBi enc
] & catMaybes & HashSet.fromList
let decrypt = [ Text.unpack o
| ListVal @C (Key "decrypt" [LitStrVal o]) <- conf
]
let keyrings = [ Text.unpack o | ListVal @C (Key "keyring" [LitStrVal o]) <- universeBi enc
] <> decrypt <> found
& List.nub
forM_ keyrings $ \k -> void $ runMaybeT do
trace $ "loadKeys: keyring" <+> pretty k
(_, pc) <- loadKeyring k
forM_ (view peerKeyring pc) $ \ke -> do
let pk = view krPk ke
trace $ "loadKeyring: key" <+> pretty (AsBase58 pk)
lift $ addEncryptionKey ke
where
findKeyFiles w = do
let flt = makeFilter <$> w
maybe1 flt (pure mempty) $
\(p, fmask) -> liftIO do
getDirectoryFiles p fmask <&> fmap (p</>)

22
hbs2-git/lib/HBS2Git/Config.hs
View File

@ -4,6 +4,7 @@ module HBS2Git.Config
) where
import HBS2.Prelude
import HBS2.Base58
import HBS2.System.Logger.Simple
import HBS2.OrDie
@ -18,9 +19,6 @@ import System.FilePath
import System.Directory
import System.Environment
import System.IO (stderr)
-- type C = MegaParsec
appName :: FilePath
appName = "hbs2-git"
@ -57,6 +55,8 @@ configPath _ = liftIO do
pwd <- liftIO getCurrentDirectory
git <- findGitDir pwd
byEnv <- lookupEnv "GIT_DIR"
-- hPrint stderr ("BY-ENV", byEnv)
-- hPrint stderr =<< getEnvironment
path <- pure (git <|> byEnv) `orDie` "*** hbs2-git: .git directory not found"
pure (takeDirectory path </> ".hbs2")
@ -70,11 +70,9 @@ data ConfigPathInfo = ConfigPathInfo {
getConfigPathInfo :: MonadIO m => m ConfigPathInfo
getConfigPathInfo = do
trace "getConfigPathInfo"
gitDir <- findWorkingGitDir
pwd <- configPath "" <&> takeDirectory
confP <- configPath pwd
confP <- configPath ""
let pwd = takeDirectory confP
let confFile = confP </> "config"
trace $ "git dir" <+> pretty gitDir
trace $ "confPath:" <+> pretty confP
pure ConfigPathInfo {
configRepoParentDir = pwd,
@ -100,3 +98,13 @@ configInit = liftIO do
cookieFile :: MonadIO m => m FilePath
cookieFile = configPath "" <&> (</> "cookie")
getAppStateDir :: forall m . MonadIO m => m FilePath
getAppStateDir = liftIO $ getXdgDirectory XdgData appName
makeDbPath :: MonadIO m => RepoRef -> m FilePath
makeDbPath h = do
state <- getAppStateDir
liftIO $ createDirectoryIfMissing True state
pure $ state </> show (pretty (AsBase58 h))

57
hbs2-git/lib/HBS2Git/Encryption.hs Normal file
View File

@ -0,0 +1,57 @@
module HBS2Git.Encryption
( module HBS2Git.Encryption
, module HBS2Git.Encryption.KeyInfo
, module HBS2.Net.Auth.GroupKeySymm
) where
import HBS2.Prelude.Plated
import HBS2.Base58
import HBS2.Net.Proto.Types hiding (Cookie)
import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
import HBS2.Net.Proto.Definition()
import HBS2Git.Encryption.KeyInfo
import Data.Config.Suckless.Syntax
import Data.Config.Suckless.KeyValue
import Data.Function
import Data.HashSet qualified as HashSet
import Data.Maybe
import Data.Text qualified as Text
import Data.Time.Clock.POSIX
-- type ForEncryption ?
isRefEncrypted :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m Bool
isRefEncrypted ref = do
conf <- getConf
let ee = [ True
| (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : _)) <- conf
, fromStringMay (Text.unpack r) == Just ref
]
-- liftIO $ hPutDoc stderr $ "isRefEncrypted" <+> pretty (AsBase58 ref) <+> pretty ee <+> pretty (not (null ee)) <> line
pure $ not $ null ee
getKeyInfo :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m (Maybe KeyInfo)
getKeyInfo ref = do
conf <- getConf
now <- liftIO getPOSIXTime
let every = [ keyInfoFrom now syn | syn <- conf
, isJust (keyInfoFrom now syn)
] & catMaybes
pure (lastMay [ x | x <- every, keyInfoRef x == ref ])
genGK0 :: (MonadIO m) => KeyInfo -> m (GroupKey 'Symm HBS2Basic)
genGK0 ki = generateGroupKey @HBS2Basic Nothing members
where
members = HashSet.toList ( keyInfoOwner ki `HashSet.insert` keyInfoMembers ki )

55
hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs Normal file
View File

@ -0,0 +1,55 @@
module HBS2Git.Encryption.KeyInfo where
import HBS2.Prelude.Plated
import HBS2.Hash
import HBS2.Net.Proto.Types hiding (Cookie)
-- import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
import HBS2.Net.Proto.Definition()
import Data.Config.Suckless.Syntax
import Data.Config.Suckless.KeyValue
import Codec.Serialise
import Data.HashSet
import Data.HashSet qualified as HashSet
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Maybe
data KeyInfo =
KeyInfo
{ keyInfoNonce :: Integer
, keyInfoRef :: PubKey 'Sign HBS2Basic
, keyInfoOwner :: PubKey 'Encrypt HBS2Basic
, keyInfoMembers :: HashSet (PubKey 'Encrypt HBS2Basic)
}
deriving (Eq,Ord,Show,Generic)
instance Serialise KeyInfo
instance Hashed HbSync KeyInfo where
hashObject ki = hashObject (serialise ki)
keyInfoFrom :: POSIXTime -> Syntax C -> Maybe KeyInfo
keyInfoFrom t (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) =
KeyInfo <$> nonce
<*> ref
<*> owner
<*> members
where
nonce = Just $ maybe 0 (round t `div`) ttl
ref = fromStringMay (Text.unpack r)
ttl = Just $ lastDef 86400 [ x | ListVal @C (Key "ttl" [LitIntVal x]) <- args ]
owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal @C (Key "owner" [LitStrVal o]) <- args ]
members = Just $ HashSet.fromList
$ catMaybes
[ fromStringMay (Text.unpack o) | ListVal @C (Key "member" [LitStrVal o]) <- args ]
-- keypath = lastMay [ Text.unpack p | ListVal @C (Key "keyring" [LitStrVal p]) <- args ]
keyInfoFrom _ _ = Nothing

45
hbs2-git/lib/HBS2Git/Export.hs
View File

@ -14,7 +14,6 @@ import HBS2.Data.Types.Refs
import HBS2.OrDie
import HBS2.System.Logger.Simple
import HBS2.Net.Proto.Definition()
import HBS2.Clock
import HBS2.Base58
import HBS2.Net.Proto.RefLog
@ -24,6 +23,7 @@ import HBS2.Git.Local.CLI
import HBS2Git.App
import HBS2Git.State
import HBS2Git.Config
import HBS2Git.KeysMetaData
import HBS2Git.GitRepoLog
import HBS2Git.PrettyStuff
@ -77,6 +77,7 @@ exportRefDeleted :: forall o m . ( MonadIO m
, MonadUnliftIO m
, HasConf m
, HasRefCredentials m
, HasEncryptionKeys m
, HasProgress m
, HasStorage m
, HasRPC m
@ -131,7 +132,9 @@ exportRefDeleted _ repo ref = do
<> "type:" <+> "hbs2-git-push-log"
<> line
logMerkle <- storeObject meta content `orDie` [qc|Can't store push log|]
updateGK0 repo
logMerkle <- storeObject repo meta content `orDie` [qc|Can't store push log|]
postRefUpdate repo 0 logMerkle
pure logMerkle
@ -155,6 +158,20 @@ newtype ExportT m a = ExportT { fromExportT :: ReaderT ExportEnv m a }
, MonadThrow
)
instance (Monad m, HasStorage m) => HasStorage (ExportT m) where
getStorage = lift getStorage
instance (Monad m, HasConf m) => HasConf (ExportT m) where
getConf = lift getConf
instance (Monad m, HasRPC m) => HasRPC (ExportT m) where
getRPC = lift getRPC
instance (Monad m, HasEncryptionKeys m) => HasEncryptionKeys (ExportT m) where
addEncryptionKey = lift . addEncryptionKey
findEncryptionKey k = lift $ findEncryptionKey k
enumEncryptionKeys = lift enumEncryptionKeys
withExportEnv :: MonadIO m => ExportEnv -> ExportT m a -> m a
withExportEnv env f = runReaderT (fromExportT f) env
@ -163,16 +180,18 @@ writeLogSegments :: forall m . ( MonadIO m
, HasRPC m
, MonadMask m
, HasRefCredentials m
, HasEncryptionKeys m
, HasConf m
)
=> ( Int -> m () )
-> RepoRef
-> GitHash
-> [GitHash]
-> Int
-> [(GitLogEntry, LBS.ByteString)]
-> ExportT m [HashRef]
writeLogSegments onProgress val objs chunkSize trailing = do
writeLogSegments onProgress repo val objs chunkSize trailing = do
db <- asks $ view exportDB
written <- asks $ view exportWritten
@ -233,7 +252,8 @@ writeLogSegments onProgress val objs chunkSize trailing = do
let gzipped = compressWith compressOpts content
logMerkle <- lift $ storeObject meta gzipped `orDie` [qc|Can't store push log|]
-- let nonce = hashObject @HbSync (serialise segments)
logMerkle <- lift $ storeObject repo meta gzipped `orDie` [qc|Can't store push log|]
trace $ "PUSH LOG HASH: " <+> pretty logMerkle
trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle
@ -250,6 +270,7 @@ exportRefOnly :: forall o m . ( MonadIO m
, MonadUnliftIO m
, HasConf m
, HasRefCredentials m
, HasEncryptionKeys m
, HasProgress m
, HasStorage m
, HasRPC m
@ -275,6 +296,8 @@ exportRefOnly _ remote rfrom ref val = do
h <- MaybeT $ readRef remote
calcRank h
updateGK0 remote
trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val
-- 1. get max ref value for known REMOTE branch
@ -362,10 +385,10 @@ exportRefOnly _ remote rfrom ref val = do
-- we need context entries to determine log HEAD operation sequence
-- so only the last section needs it alongwith headEntry
logz <- lift $ withExportEnv env (writeLogSegments upd val objects batch [ (ctx, ctxBs)
, (rank, rankBs)
, (headEntry, repoHeadStr)
])
logz <- lift $ withExportEnv env (writeLogSegments upd remote val objects batch [ (ctx, ctxBs)
, (rank, rankBs)
, (headEntry, repoHeadStr)
])
-- NOTE: отдаём только последнюю секцию лога,
-- что бы оставить совместимость
@ -373,6 +396,8 @@ exportRefOnly _ remote rfrom ref val = do
---
runExport :: forall m . ( MonadIO m
, MonadUnliftIO m
, MonadCatch m
@ -380,11 +405,13 @@ runExport :: forall m . ( MonadIO m
, MonadMask (App m)
, HasStorage (App m)
, HasRPC (App m)
, HasEncryptionKeys (App m)
)
=> Maybe FilePath -> RepoRef -> App m ()
runExport mfp repo = do
loadCredentials (maybeToList mfp)
loadKeys
let krf = fromMaybe "keyring-file" mfp & takeFileName
runExport'' krf repo
@ -397,12 +424,14 @@ runExport' :: forall m . ( MonadIO m
, MonadMask (App m)
, HasStorage (App m)
, HasRPC (App m)
, HasEncryptionKeys (App m)
)
=> FilePath -> App m ()
runExport' fp = do
repo <- loadCredentials' fp
loadKeys
runExport'' (takeFileName fp) (RefLogKey repo)
---

76
hbs2-git/lib/HBS2Git/Import.hs
View File

@ -7,6 +7,9 @@ import HBS2.OrDie
import HBS2.System.Logger.Simple
import HBS2.Merkle
import HBS2.Hash
import HBS2.Storage.Operations.Class
import HBS2.Storage.Operations.ByteString(TreeKey(..))
import HBS2.Net.Auth.GroupKeySymm
import HBS2.Net.Proto.RefLog
import Text.InterpolatedString.Perl6 (qc)
import HBS2.Data.Detect hiding (Blob)
@ -14,7 +17,9 @@ import HBS2.Data.Detect hiding (Blob)
import HBS2.Git.Local
import HBS2Git.GitRepoLog
import HBS2Git.App
import HBS2Git.Config
import HBS2Git.State
import HBS2Git.KeysMetaData
import HBS2.Git.Local.CLI
import Data.Fixed
@ -27,6 +32,7 @@ import Data.ByteString.Lazy.Char8 qualified as LBS
import Lens.Micro.Platform
import Data.Set qualified as Set
import Codec.Serialise
import Control.Monad.Except (runExceptT)
import Control.Monad.Catch
import Control.Monad.Trans.Resource
import System.Directory
@ -36,12 +42,13 @@ import System.IO (openBinaryFile)
import System.FilePath.Posix
import Data.HashMap.Strict qualified as HashMap
import Data.Text qualified as Text
import Data.Config.Suckless
import Data.Either
import Streaming.ByteString qualified as SB
import Streaming.Zip qualified as SZip
import HBS2Git.PrettyStuff
data RunImportOpts =
RunImportOpts
{ _runImportDry :: Maybe Bool
@ -114,6 +121,7 @@ importRefLogNew :: ( MonadIO m
, MonadCatch m
, MonadMask m
, HasStorage m
, HasEncryptionKeys m
, HasImportOpts opts
)
=> opts -> RepoRef -> m ()
@ -122,6 +130,8 @@ importRefLogNew opts ref = runResourceT do
let force = importForce opts
sto <- getStorage
let myTempDir = "hbs-git"
temp <- liftIO getCanonicalTemporaryDirectory
(_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
@ -158,12 +168,22 @@ importRefLogNew opts ref = runResourceT do
sp0 <- withDB db savepointNew
withDB db $ savepointBegin sp0
-- TODO: scan-metadata-transactions-first
-- Сканируем транзы, обрабатываем транзакции с метаданными
-- Пишем транзакции с журналами, что бы обрабатывались следующим
-- проходом только они. Таким образом не меняется сложность.
decrypt <- lift enumEncryptionKeys
debug $ "Decrypt" <> vcat (fmap pretty decrypt)
-- TODO: exclude-metadata-transactions
forM_ entries $ \e -> do
missed <- lift $ readBlock e <&> isNothing
when missed do
debug $ "MISSED BLOCK" <+> pretty e
warn $ "MISSED BLOCK" <+> pretty e
let fname = show (pretty e)
let fpath = dir </> fname
@ -172,9 +192,14 @@ importRefLogNew opts ref = runResourceT do
runMaybeT $ do
bs <- MaybeT $ lift $ readBlock e
refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs & either (const Nothing) Just
payload <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just
let (SequentialRef _ (AnnotatedHashRef _ h)) = payload
refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs
payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd)
-- NOTE: good-place-to-process-hash-log-update-first
let (SequentialRef _ (AnnotatedHashRef ann' h)) = payload
forM_ ann' (withDB db . importKeysAnnotations ref e)
trace $ "PUSH LOG HASH" <+> pretty h
treeBs <- MaybeT $ lift $ readBlock h
@ -197,10 +222,43 @@ importRefLogNew opts ref = runResourceT do
unless (here && not force) do
(src, enc) <- case something of
MerkleAnn (MTreeAnn _ sc@(EncryptGroupNaClSymm g nonce) tree) -> do
gk10' <- runExceptT $ readFromMerkle sto (SimpleKey g)
-- FIXME: nicer-error-handling
gk10'' <- either (const $ err ("GK0 not found:" <+> pretty g) >> mzero) pure gk10'
gk10 <- toMPlus (deserialiseOrFail gk10'')
gk11 <- withDB db $ stateListGK1 (HashRef g)
let gk1 = mconcat $ gk10 : gk11
-- elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS decrypt (fromHashRef h))
elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS2 gk1 nonce decrypt tree)
case elbs of
Left{} -> do
let lock = toStringANSI $ red "x"
hPutStrLn stderr [qc|import [{lock}] {pretty e}|]
mzero
Right lbs -> (,True) <$> pure do
SB.fromLazy lbs
pure (fromIntegral (LBS.length lbs))
-- FIXME: remove-debug
MerkleAnn{} -> pure (blockSource h, False)
_ -> pure (blockSource h, False)
sz <- if gzipped then do
SB.toHandle fh $ SZip.gunzip (blockSource h)
SB.toHandle fh $ SZip.gunzip src
else
SB.toHandle fh (blockSource h)
SB.toHandle fh src
release keyFh
@ -213,8 +271,10 @@ importRefLogNew opts ref = runResourceT do
num <- liftIO $ readTVarIO tnum
trace $ "LOG ENTRY COUNT" <+> pretty num
let lock = toStringANSI $ if enc then yellow "@" else " "
let pref = take 16 (show (pretty e))
let name = [qc|import {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|]
let name = [qc|import [{lock}] {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|]
oMon <- newProgressMonitor name num

80
hbs2-git/lib/HBS2Git/KeysCommand.hs Normal file
View File

@ -0,0 +1,80 @@
module HBS2Git.KeysCommand
( module HBS2Git.KeysCommand
, module HBS2.Net.Proto.Types
, CryptoAction(..)
) where
import HBS2.Prelude.Plated
import HBS2.Base58
import HBS2.OrDie
import HBS2.Net.Proto.Types
import HBS2Git.App
import HBS2Git.Encryption
import HBS2.System.Logger.Simple
import Data.Function
import Data.Time.Clock.POSIX
import Data.Maybe
runKeyRefsList :: (MonadIO m, HasConf m) => m ()
runKeyRefsList = do
conf <- getConf
now <- liftIO getPOSIXTime
let every = [ keyInfoRef <$> keyInfoFrom now syn | syn <- conf
, isJust (keyInfoFrom now syn)
] & catMaybes
liftIO $ print $ vcat (fmap (pretty . AsBase58) every)
runKeysUpdate :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m ()
runKeysUpdate ref = do
conf <- getConf
-- TODO: generate-GK0
-- generate basic key for OWNER only
now <- liftIO getPOSIXTime
let every = [ keyInfoFrom now syn | syn <- conf
, isJust (keyInfoFrom now syn)
] & catMaybes
this <- pure (lastMay [ x | x <- every, keyInfoRef x == ref ])
`orDie` "Not found encrypted section for given ref"
gk0 <- generateGroupKey @HBS2Basic Nothing [keyInfoOwner this]
pure ()
-- now <- liftIO getPOSIXTime
-- let every = [ keyInfoFrom now syn | syn <- conf
-- , isJust (keyInfoFrom now syn)
-- ] & catMaybes
-- let keys = [ x | x <- every, keyInfoRef x == ref ]
-- info $ viaShow keys
runKeysList :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m ()
runKeysList ref = do
conf <- getConf
now <- liftIO getPOSIXTime
let every = [ keyInfoFrom now syn | syn <- conf
, isJust (keyInfoFrom now syn)
] & catMaybes
let keys = [ x | x <- every, keyInfoRef x == ref ]
info $ viaShow keys

266
hbs2-git/lib/HBS2Git/KeysMetaData.hs Normal file
View File

@ -0,0 +1,266 @@
module HBS2Git.KeysMetaData where
import HBS2.Prelude.Plated
import HBS2.Hash
import HBS2.Base58
import HBS2.Data.Detect
import HBS2.Data.Types.Refs
import HBS2.Merkle
import HBS2.Net.Auth.GroupKeySymm
import HBS2.Net.Proto.RefLog
import HBS2.OrDie
import HBS2.Storage
import HBS2.Storage.Operations.ByteString
import HBS2.System.Logger.Simple
import HBS2.Net.Proto.Definition()
import HBS2Git.Types
import HBS2Git.Alerts
import HBS2Git.Annotations
import HBS2Git.Encryption
import HBS2Git.State
import HBS2Git.PrettyStuff
import HBS2Git.Config
import Codec.Serialise
import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Either
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.List qualified as List
import Data.Function (on)
import Data.Maybe
import Lens.Micro.Platform
import Streaming.Prelude qualified as S
import System.IO
import Text.InterpolatedString.Perl6 (qc)
updateGK0 :: forall m . ( MonadIO m
-- , HasRPC m
, MonadMask m
, HasStorage m
, HasConf m
, HasEncryptionKeys m
)
=> RepoRef
-> m ()
updateGK0 repo = void $ runMaybeT do
guard =<< lift (isRefEncrypted (fromRefLogKey repo))
db <- makeDbPath repo >>= dbEnv
-- FIXME: check-if-for-die-good-here
ki <- lift $ getKeyInfo (fromRefLogKey repo)
`orDie` noKeyInfoMsg repo
-- 2. Если нет GK0 или он expired
mbGk0Hash <- withDB db $ stateGetLocalKey ki
-- 2.1 Генерируем новый GK0
gk0Hash <- lift $ maybe1 mbGk0Hash (makeNewGK0 ki) pure
when (isNothing mbGk0Hash) do
liftIO $ hPutDoc stderr $ "New GK0" <+> pretty gk0Hash <> line
withDB db $ statePutLocalKey ki gk0Hash repo
debug $ "GK0" <+> pretty gk0Hash
where
makeNewGK0 ki = do
sto <- getStorage
gk <- genGK0 ki <&> serialise
liftIO $ writeAsMerkle sto (gk :: ByteString) <&> HashRef
genKeysAnnotations :: forall m . ( MonadIO m
, MonadMask m
, HasStorage m
, HasConf m
, HasEncryptionKeys m
)
=> RepoRef
-> m (Maybe HashRef)
genKeysAnnotations repo = do
sto <- getStorage
runMaybeT do
guard =<< lift (isRefEncrypted (fromRefLogKey repo))
db <- makeDbPath repo >>= dbEnv
-- TODO: generate-and-update-keys-metadata
-- 1. get GK0
ki <- lift $ getKeyInfo (fromRefLogKey repo)
`orDie` noKeyInfoMsg repo
gk0Hash <- withDB db $ stateGetLocalKey ki
`orDie` noKeyInfoMsg repo
let processedKey = serialise ("GENKEYMETADATA", gk0Hash)
isNewKey <- withDB db $ not <$> stateGetProcessed processedKey
sp0 <- withDB db savepointNew
withDB db $ savepointBegin sp0
-- FIXME: excess-data-roundtrip
gk0newBs <- (runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gk0Hash))))
`orDie` [qc|*** Can't load GK0 {pretty gk0Hash}, maybe storage failure|]
-- теперь нам надо как-то узнать, что ключ новый и нам надо обработать
-- новых читателей.
-- Вариант #1: писать авторов в стейт. если они не обработаны еще,
-- то обрабатывать.
-- 2.2 Генерируем новый GK1 ∀ members
-- FIXME: might-be-slow
guard isNewKey
-- notice $ "NEW KEY APPEARED" <+> pretty gk0Hash
h <- toMPlus =<< getRef sto (refAlias repo)
gk0hs <- HashSet.fromList <$> S.toList_ (findAllGK0 sto h)
let keySource = do
forM_ gk0hs $ \gkh -> void $ runMaybeT do
gbs <- toMPlus =<< runExceptT (readFromMerkle sto (SimpleKey gkh))
gk0 <- toMPlus $ deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gbs
-- TODO: decrypt-secret-right-here
lift $ S.yield (gkh, gk0)
allKeys <- S.toList_ keySource <&> HashMap.fromList
-- ∀ gk0:
-- - вытащить секрет (найти, кем расшифровать) recipients
-- - взять вообще всех recipients и сформировать новый GK1
-- для каждого из recipients из allKeys
-- взять все доступные пары ключей?
keys <- lift enumEncryptionKeys <&> fmap (\x -> (view krPk x, view krSk x))
new' <- forM (HashMap.toList allKeys) $ \(hx, gk0) -> do
let gksec' = [ lookupGroupKey sk pk gk0 | (pk,sk) <- keys ] & catMaybes & headMay
case gksec' of
Nothing -> pure (Left hx)
Just sec -> pure $ Right (hx, gk0, sec)
let missed = lefts new'
forM_ missed $ \miss -> do
warn $ "new group key: unavailable keys for gk" <+> pretty miss
let new = rights new'
gk0new <- pure (deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gk0newBs)
`orDie` [qc|*** Malformed/corrupted group key {pretty gk0Hash}|]
let rcpt0 = recipients gk0new
gnew <- forM new $ \(hx, gk0, sec) -> do
-- TODO: test-if-key-removing-works
let newRcpt = (recipients gk0new & HashMap.keysSet)
`HashSet.difference`
(recipients gk0 & HashMap.keysSet)
let r1 = HashMap.keys $ recipients gk0 <> recipients gk0new
let r11 = [ x | x <- r1, HashMap.member x rcpt0 ]
gk1 <- generateGroupKey @HBS2Basic (Just sec) r11
pure (hx, newRcpt, gk1)
let nr = HashSet.unions $ fmap (view _2) gnew
ann <- if HashSet.null nr then do
pure mempty
else do
forM gnew $ \(gk0h, _, gk1) -> do
pure (GK1 (HashRef gk0h) gk1)
annHash <- if List.null ann then do
pure Nothing
else do
Just . HashRef <$> writeAsMerkle sto (serialise (SmallAnnotations ann))
debug $ "ANNOTATIONS" <+> pretty annHash
withDB db do
statePutProcessed processedKey
savepointRelease sp0
toMPlus annHash
where
-- FIXME: deepScan-ScanShallow-broken
-- TODO: deal-with-missed-blocks
findAllGK0 sto h = do
-- TODO: performance-memoize-possible
-- можно мемоизировать для h
deepScan ScanDeep (const none) h (getBlock sto) $ \hx -> do
void $ runMaybeT do
blk <- toMPlus =<< getBlock sto hx
refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) blk
payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd)
let (SequentialRef _ (AnnotatedHashRef _ ht)) = payload
treeBs <- toMPlus =<< getBlock sto (fromHashRef ht)
enc <- toMPlus (deserialiseOrFail @(MTreeAnn [HashRef]) treeBs)
<&> _mtaCrypt
case enc of
EncryptGroupNaClSymm g _ -> do
-- liftIO $ hPutDoc stderr $ "GK0 FOR" <+> pretty
lift $ S.yield g
_ -> pure ()
importKeysAnnotations :: forall m . ( MonadIO m
, MonadMask m
, HasStorage m
)
=> RepoRef
-> HashRef
-> HashRef
-> DB m ()
importKeysAnnotations repo e href = do
sto <- lift getStorage
-- db <- makeDbPath repo >>= dbEnv
void $ runMaybeT do
-- liftIO $ hPutDoc stderr $ "GOT ANNOTATION" <+> pretty e <+> pretty href <> line
ebs <- runExceptT $ readFromMerkle sto (SimpleKey (fromHashRef href))
bs <- toMPlus ebs
anns <- toMPlus $ deserialiseOrFail @Annotations bs
let entries = case anns of
SmallAnnotations e -> [ gk1 | gk1@(GK1{}) <- e ]
_ -> mempty
forM_ entries $ \(GK1 gk0h gk1) -> do
-- liftIO $ hPutDoc stderr $ "IMPORTING GK1 FOR" <+> pretty gk0h <> line
forM_ (HashMap.toList (recipients gk1)) $ \(pk,box) -> do
let gk1small = GroupKeySymm @HBS2Basic (HashMap.singleton pk box)
lift $ statePutGK1 gk0h pk gk1small

3
hbs2-git/lib/HBS2Git/ListRefs.hs
View File

@ -1,5 +1,7 @@
module HBS2Git.ListRefs where
import HBS2.Prelude
import HBS2Git.Types
import HBS2.Prelude
import HBS2Git.App
@ -9,6 +11,7 @@ import HBS2.System.Logger.Simple
import HBS2.Git.Local.CLI
import HBS2.Git.Types
import HBS2Git.Import (importRefLogNew)
import HBS2Git.Config
import HBS2Git.State
import HBS2Git.PrettyStuff

14
hbs2-git/lib/HBS2Git/PrettyStuff.hs
View File

@ -1,5 +1,9 @@
module HBS2Git.PrettyStuff where
module HBS2Git.PrettyStuff
( module HBS2Git.PrettyStuff
, hPutDoc
) where
import Data.Text qualified as Text
import Prettyprinter
import Prettyprinter.Render.Terminal
@ -9,9 +13,15 @@ green = annotate (color Green)
yellow :: Doc AnsiStyle -> Doc AnsiStyle
yellow = annotate (color Yellow)
red :: Doc AnsiStyle -> Doc AnsiStyle
red = annotate (color Red)
blue :: Doc AnsiStyle -> Doc AnsiStyle
blue = annotate (color Blue)
section :: Doc ann
section = line <> line
toStringANSI :: Doc AnsiStyle -> String
toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc

133
hbs2-git/lib/HBS2Git/State.hs
View File

@ -1,7 +1,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language UndecidableInstances #-}
module HBS2Git.State where
import HBS2.Prelude
import HBS2.Base58
import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
import HBS2Git.Types
import HBS2.Data.Types.Refs
import HBS2.Git.Types
@ -10,6 +14,7 @@ import HBS2.Hash
import HBS2.System.Logger.Simple
import HBS2Git.Config (cookieFile)
import HBS2Git.Encryption
import Control.Monad.Trans.Resource
import Data.Functor
@ -63,6 +68,19 @@ instance ToField GitObjectType where
instance FromField HashRef where
fromField = fmap fromString . fromField @String
instance ToField (RefLogKey HBS2Basic) where
toField rk = toField (show (pretty rk))
newtype Base58Field a = Base58Field { unBaseB8Field :: a }
instance Pretty (AsBase58 a) => ToField (Base58Field a) where
toField (Base58Field a) = toField (show (pretty (AsBase58 a)))
instance FromStringMaybe a => FromField (Base58Field a) where
fromField x =
fromField @String x
<&> fromStringMay @a
>>= maybe (fail "can't parse base58 value") (pure . Base58Field)
newtype DB m a =
DB { fromDB :: ReaderT DBEnv m a }
@ -216,6 +234,35 @@ stateInit = do
);
|]
liftIO $ execute_ conn [qc|
CREATE TABLE IF NOT EXISTS groupkeylocal
( keyhash text not null
, ref text not null
, timestamp DATETIME DEFAULT CURRENT_TIMESTAMP
, valuehash text not null
, primary key (keyhash)
);
|]
liftIO $ execute_ conn [qc|
CREATE TABLE IF NOT EXISTS gk1
( gk0 text not null
, pk text not null
, gk1 text not null
, primary key (gk0, pk)
);
|]
liftIO $ execute_ conn [qc|
CREATE TABLE IF NOT EXISTS processed
( hash text not null
, cookie text not null
, timestamp DATETIME DEFAULT CURRENT_TIMESTAMP
, primary key (hash)
);
|]
liftIO $ execute_ conn [qc|
DROP VIEW IF EXISTS v_log_depth;
|]
@ -523,3 +570,89 @@ stateGenCookie = do
pure cookie
stateListLocalKeys :: MonadIO m => DB m [HashRef]
stateListLocalKeys = do
undefined
stateGetLocalKey :: MonadIO m
=> KeyInfo
-> DB m (Maybe HashRef)
stateGetLocalKey ki = do
conn <- stateConnection
let h = hashObject @HbSync ki & HashRef
liftIO $ query conn [qc|select valuehash from groupkeylocal where keyhash = ? limit 1|] (Only h)
<&> fmap fromOnly . listToMaybe
statePutLocalKey :: MonadIO m
=> KeyInfo
-> HashRef
-> RefLogKey HBS2Basic
-> DB m ()
statePutLocalKey ki gkh reflog = do
conn <- stateConnection
let sql = [qc|
INSERT INTO groupkeylocal (keyhash, ref, valuehash)
VALUES (?,?,?)
ON CONFLICT (keyhash) DO UPDATE SET
ref = excluded.ref, valuehash = excluded.valuehash
|]
liftIO $ execute conn sql (HashRef (hashObject @HbSync ki), reflog, gkh)
pure ()
statePutProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m ()
statePutProcessed h = do
conn <- stateConnection
cookie <- asks (view dbCookie)
liftIO $ execute conn [qc|
insert into processed (hash, cookie) values (?, ?)
on conflict (hash) do nothing
|] (HashRef (hashObject @HbSync h), cookie)
stateGetProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m Bool
stateGetProcessed h = do
conn <- stateConnection
cookie <- asks (view dbCookie)
r <- liftIO $ query @_ @(Only Int) conn [qc|
select 1 from processed where hash = ? and cookie = ? limit 1
|] (HashRef (hashObject @HbSync h), cookie)
pure $ not $ null r
statePutGK1 :: MonadIO m => HashRef
-> PubKey 'Encrypt HBS2Basic
-> GroupKey 'Symm HBS2Basic
-> DB m ()
statePutGK1 gk0 pk gk1 = do
conn <- stateConnection
liftIO $ execute conn [qc|
insert into gk1 (gk0, pk, gk1) values (?, ?, ?)
on conflict (gk0, pk) do nothing
|] (gk0, Base58Field pk, Base58Field gk1)
stateGetGK1 :: MonadIO m
=> HashRef
-> PubKey 'Encrypt HBS2Basic
-> DB m (Maybe (GroupKey 'Symm HBS2Basic))
stateGetGK1 gk0 pk = do
conn <- stateConnection
r <- liftIO $ query conn [qc|
select gk1 from gk1 where gk0 = ? and pk = ? limit 1
|] (gk0, Base58Field pk)
pure $ listToMaybe $ fmap (unBaseB8Field . fromOnly) r
stateListGK1 :: MonadIO m
=> HashRef
-> DB m [GroupKey 'Symm HBS2Basic]
stateListGK1 gk0 = do
conn <- stateConnection
r <- liftIO $ query conn [qc|
select gk1 from gk1 where gk0 = ?
|] (Only gk0)
pure $ fmap (unBaseB8Field . fromOnly) r

24
hbs2-git/lib/HBS2Git/Types.hs
View File

@ -6,18 +6,19 @@ module HBS2Git.Types
( module HBS2Git.Types
, module Control.Monad.IO.Class
, HasStorage(..)
, HasConf(..)
, AnyStorage(..)
, RefLogKey(..)
)
where
import HBS2.Prelude.Plated
import HBS2.Hash
import HBS2.Base58
import HBS2.Clock
import HBS2.Git.Types
import HBS2.Actors.Peer.Types (HasStorage(..),AnyStorage(..))
import HBS2.Peer.RPC.Client.Unix hiding (Cookie)
import HBS2.Net.Proto.RefLog (RefLogKey(..))
import HBS2.Net.Proto.Types hiding (Cookie)
import HBS2.Net.Auth.Credentials
import HBS2.Peer.RPC.API.Peer
@ -30,13 +31,9 @@ import Data.Config.Suckless
import System.ProgressBar
import System.Exit as Exit
import Control.Monad.Trans.Maybe
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text qualified as Text
import Data.Text (Text)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Database.SQLite.Simple (Connection)
import Data.Char (isSpace)
@ -44,14 +41,12 @@ import Data.List qualified as List
import Lens.Micro.Platform
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Codec.Serialise
import Control.Concurrent.STM
import System.IO qualified as IO
import System.IO (Handle)
import Data.Kind
import Control.Monad.Catch
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Resource
import System.TimeIt
@ -102,6 +97,8 @@ data AppEnv =
, _appConf :: [Syntax C]
, _appStateDir :: FilePath
, _appRefCred :: TVar (HashMap RepoRef (PeerCredentials Schema))
, _appKeys :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema))
, _appOpts :: TVar (HashMap String String)
, _appRpc :: RPCEndpoints
}
@ -184,6 +181,15 @@ class MonadIO m => HasRefCredentials m where
getCredentials :: RepoRef -> m (PeerCredentials Schema)
setCredentials :: RepoRef -> PeerCredentials Schema -> m ()
class MonadIO m => HasGlobalOptions m where
addGlobalOption :: String -> String -> m ()
getGlobalOption :: String -> m (Maybe String)
class MonadIO m => HasEncryptionKeys m where
addEncryptionKey :: KeyringEntry Schema -> m ()
findEncryptionKey :: PubKey 'Encrypt Schema -> m (Maybe (PrivKey 'Encrypt Schema))
enumEncryptionKeys :: m [KeyringEntry Schema]
newtype App m a =
App { fromApp :: ReaderT AppEnv m a }
deriving newtype ( Applicative
@ -201,6 +207,7 @@ newtype App m a =
instance MonadIO m => HasConf (App m) where
getConf = asks (view appConf)
hPrint :: (Show a, MonadIO m) => Handle -> a -> m ()
hPrint h s = liftIO $ IO.hPrint h s
@ -220,6 +227,7 @@ exitFailure = do
die :: MonadIO m => String -> m a
die s = do
shutUp
pause @'Seconds 0.1
liftIO $ Exit.die s
traceTime :: MonadIO m => String -> m a -> m a

15
hbs2-tests/test/PrototypeGenericService.hs
View File

@ -41,9 +41,11 @@ instance HasProtocol UNIX (ServiceProto MyServiceMethods1 UNIX) where
-- instance (MonadIO m, HasProtocol UNIX (ServiceProto MyServiceMethods1 UNIX)) => HasTimeLimits UNIX (ServiceProto MyServiceMethods1 UNIX) m where
-- tryLockForPeriod _ _ = pure True
type instance Input Method1 = String
type instance Output Method1 = String
instance MonadIO m => HandleMethod m Method1 where
type instance Input Method1 = String
type instance Output Method1 = String
handleMethod n = do
debug $ "SERVICE1. METHOD1" <+> pretty n
case n of
@ -51,11 +53,12 @@ instance MonadIO m => HandleMethod m Method1 where
"PECHEN" -> pure "TRESKI"
_ -> pure "X3"
instance MonadIO m => HandleMethod m Method2 where
type instance Input Method2 = ()
type instance Output Method2 = ()
handleMethod _ = pure ()
type instance Input Method2 = ()
type instance Output Method2 = ()
instance MonadIO m => HandleMethod m Method2 where
handleMethod _ = pure ()
instance (HasProtocol UNIX (ServiceProto api UNIX), MonadUnliftIO m)
=> HasDeferred UNIX (ServiceProto api UNIX) m where

12
hbs2/Main.hs
View File

@ -378,7 +378,7 @@ runStore opts ss = runResourceT do
let segments = readChunked fh (fromIntegral defBlockSize)
let source = ToEncryptSymmBS gks nonce segments gk
let source = ToEncryptSymmBS gks nonce segments gk NoMetaData
r <- runExceptT $ writeAsMerkle ss source
@ -415,9 +415,10 @@ runNewGroupKeyAsymm pubkeysFile = do
List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk
print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey
runNewKey :: forall s . (s ~ HBS2Basic) => IO ()
runNewKey = do
cred <- newCredentials @s
runNewKey :: forall s . (s ~ HBS2Basic) => Int -> IO ()
runNewKey n = do
cred0 <- newCredentials @s
cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
print $ pretty $ AsCredFile $ AsBase58 cred
runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
@ -649,7 +650,8 @@ main = join . customExecParser (prefs showHelpOnError) $
pure $ withStore o $ runHash $ HashOpts hash
pNewKey = do
pure runNewKey
n <- optional $ option auto ( short 'n' <> long "number")
pure $ runNewKey (fromMaybe 0 n)
pShowPeerKey = do
fp <- optional $ strArgument ( metavar "FILE" )