encryption to check

hbs2-core/lib/HBS2/Merkle.hs

@@ -7,11 +7,12 @@ import HBS2.Hash
 
 import Codec.Serialise
 import Data.ByteString (ByteString)
-import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
 import Data.Data
 import Data.Foldable (forM_, traverse_)
 import Data.List qualified as List
+import Data.Text (Text)
 import GHC.Generics
 import Lens.Micro.Platform
 import Prettyprinter
@@ -76,8 +77,14 @@ makeLenses ''MNodeData
 
 instance Serialise MNodeData
 
+data AnnMetaData = NoMetaData | ShortMetadata Text | AnnHashRef (Hash HbSync)
+  deriving stock (Generic,Data,Show)
+
+instance Serialise AnnMetaData
+
 data MTreeAnn a = MTreeAnn
- { _mtaAnn :: !Ann
+ { _mtaMeta :: !AnnMetaData
+ , _mtaCrypt :: !MTreeEncryption
  , _mtaTree :: !(MTree a)
  }
   deriving stock (Generic,Data,Show)
@@ -87,13 +94,12 @@ instance Serialise a => Serialise (MTreeAnn a)
 data MerkleEncryptionType
   deriving stock (Data)
 
-data Ann
+data MTreeEncryption
-  = NullAnn
+  = NullEncryption
-  | GroupKeyCrypt (Hash HbSync)
+  | CryptAccessKeyNaClAsymm (Hash HbSync)
-  -- FIXME more annotation schemes
   deriving stock (Generic,Data,Show)
 
-instance Serialise Ann
+instance Serialise MTreeEncryption
 
 data MTree a = MNode MNodeData [Hash HbSync] | MLeaf a
                deriving stock (Generic,Data,Show)

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

@@ -18,6 +18,7 @@ import HBS2.OrDie
 import HBS2.Prelude.Plated
 
 import Codec.Serialise
+import Control.Monad ((<=<))
 import Crypto.Saltine.Core.Sign (Keypair(..))
 import Crypto.Saltine.Core.Sign qualified as Sign
 import Crypto.Saltine.Core.Box qualified as Encrypt
@@ -40,9 +41,98 @@ newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString }
 
 instance Serialise EncryptedBox
 
-newtype AccessKeyV1 e = AccessKeyV1
+data EncryptionSchema = NaClAsymm
+
+---
+
+data family AccessKey e ( s :: EncryptionSchema )
+
+newtype instance AccessKey e 'NaClAsymm =
+  AccessKeyNaClAsymm
   { permitted :: [(PubKey 'Encrypt e, EncryptedBox)]
   }
   deriving stock (Generic)
 
-instance Serialise (AccessKeyV1 e)
+instance Serialise (AccessKey e 'NaClAsymm)
+
+---
+
+data family GroupKey e ( s :: EncryptionSchema )
+
+data instance GroupKey e 'NaClAsymm =
+  GroupKeyNaClAsymm
+  { encryptionKey :: KeyringEntry e
+  , permittedPubKeys :: [PubKey 'Encrypt e]
+  }
+  deriving stock (Generic)
+
+instance Serialise (GroupKey e 'NaClAsymm)
+
+---
+
+newtype AsGroupKeyFile a = AsGroupKeyFile a
+
+---- FIXME: integration-regression-test-for-groupkey
+----   Добавить тест: сгенерировали groupkey/распарсили groupkey
+
+parseGroupKey :: forall e . ()
+                 =>  AsGroupKeyFile ByteString -> Maybe (GroupKey e 'NaClAsymm)
+
+parseGroupKey (AsGroupKeyFile bs) = maybe1 b58_1 Nothing fromCbor
+
+  where
+    fromCbor s = deserialiseOrFail @(GroupKey e 'NaClAsymm) s
+                   & either (const Nothing) Just
+
+    b58_1 = B8.lines bs & dropWhile hdr
+                        & filter ( not . B8.null )
+                        & B8.concat
+                        & fromBase58
+                        & fmap LBS.fromStrict
+
+    hdr s = B8.isPrefixOf "#" s || B8.null s
+
+instance ( Serialise  (GroupKey e s)
+         )
+
+  =>  Pretty (AsBase58 (GroupKey e s)) where
+  pretty (AsBase58 c) =
+    pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
+
+
+instance Pretty (AsBase58 a) => Pretty (AsGroupKeyFile (AsBase58 a)) where
+  pretty (AsGroupKeyFile pc) =  "# hbs2 groupkey file" <> line
+                         <> "# keep it private" <> line <> line
+                         <> co
+    where
+      co = vcat $ fmap pretty
+                $ chunksOf 60
+                $ show
+                $ pretty pc
+
+
+-- newtype ListGroupKeyKeys e s = ListGroupKeyKeys (GroupKey e s)
+
+-- instance ()
+--   => Pretty (ListGroupKeyKeys e 'NaClAsymm) where
+--   pretty (ListGroupKeyKeys (GroupKeyNaClAsymm keypair pubkeys)) =
+--     fill 10 "recipient public keys:"
+--     <+> vcat (pretty . AsBase58 . Crypto.encode <$> pubkeys)
+--     <> line
+--     <> pretty keypair
+
+---
+
+parsePubKeys :: forall e . ()
+                 =>  ByteString -> Maybe [PubKey 'Encrypt e]
+
+parsePubKeys = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines
+
+---
+
+mkEncryptedKey :: KeyringEntry MerkleEncryptionType -> PubKey 'Encrypt MerkleEncryptionType -> IO EncryptedBox
+mkEncryptedKey kr pk = EncryptedBox <$> Encrypt.boxSeal pk ((LBS.toStrict . serialise) kr)
+
+openEncryptedKey :: EncryptedBox -> KeyringEntry MerkleEncryptionType -> Maybe (KeyringEntry MerkleEncryptionType)
+openEncryptedKey (EncryptedBox bs) kr =
+    deserialise . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs

hbs2-core/lib/HBS2/Net/Proto/Definition.hs

@@ -8,6 +8,7 @@ module HBS2.Net.Proto.Definition
 
 import HBS2.Clock
 import HBS2.Defaults
+import HBS2.Merkle
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Proto
@@ -140,4 +141,10 @@ instance Signatures UDP where
   makeSign = Sign.signDetached
   verifySign = Sign.signVerifyDetached
 
+instance Signatures MerkleEncryptionType where
+  type Signature MerkleEncryptionType = Sign.Signature
+  makeSign = Sign.signDetached
+  verifySign = Sign.signVerifyDetached
+
+
 

hbs2-peer/app/BlockDownload.hs

@@ -187,13 +187,18 @@ processBlock h = do
 
      Just (AnnRef{}) -> pure ()
 
-     Just (MerkleAnn (MTreeAnn ann t)) -> do
+     Just (MerkleAnn ann) -> do
-       case ann of
+       case (_mtaMeta ann) of
-            NullAnn -> pure ()
+          NoMetaData -> pure ()
-            GroupKeyCrypt hk -> addDownload hk
+          ShortMetadata {} -> pure ()
+          AnnHashRef h -> addDownload h
+
+       case (_mtaCrypt ann) of
+          NullEncryption -> pure ()
+          CryptAccessKeyNaClAsymm h -> addDownload h
 
        debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h
-       walkMerkleTree t (liftIO . getBlock sto) handleHrr
+       walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr
 
      Just (Merkle{}) -> do
        debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h

hbs2/Main.hs

@@ -16,17 +16,22 @@ import HBS2.Storage.Simple.Extra
 import HBS2.OrDie
 
 
-import Data.ByteString.Lazy (ByteString)
+import Control.Arrow ((&&&))
 import Control.Concurrent.Async
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.State.Strict
+import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
+import Data.ByteString.Lazy (ByteString)
 import Data.Either
 import Data.Function
 import Data.Functor
+import Data.Map.Strict qualified as Map
+import Data.Monoid qualified as Monoid
+import Data.Text (Text)
 import Data.UUID qualified as UUID
 import Data.UUID.V4 qualified as UUID
 import Options.Applicative
@@ -59,15 +64,18 @@ newtype CatHashesOnly = CatHashesOnly Bool
                         deriving stock (Data,Generic)
 
 
+newtype OptKeyringFile = OptKeyringFile { unOptKeyringFile :: FilePath }
+                       deriving newtype (Eq,Ord,IsString)
+                       deriving stock (Data)
+
 newtype OptInit = OptInit { fromOptInit :: Bool }
                   deriving newtype (Eq,Ord,Pretty)
                   deriving stock (Data,Generic)
 
 data OptEncryption e = OptEncryption
-  { encryptFromSecKey :: Maybe (PrivKey 'Encrypt e)
+  { encoptGroupkeyFile :: FilePath
-  , encryptToSecKey :: PrivKey 'Encrypt e
+  , encoptKeyringFile :: Maybe FilePath
-  , encryptToPubKey :: PubKey 'Encrypt e
+  , encoptFromPubKey :: Maybe Text
-  , encryptToGroup :: [PubKey 'Encrypt e]
   }
   deriving stock (Data)
 
@@ -83,7 +91,7 @@ data CatOpts =
   CatOpts
   { catMerkleHash :: Maybe MerkleHash
   , catHashesOnly :: Maybe CatHashesOnly
-  , catPathToKeyring :: Maybe FilePath
+  , catPathToKeyring :: Maybe OptKeyringFile
   }
   deriving stock (Data)
 
@@ -134,46 +142,54 @@ runCat opts ss = do
                        Nothing  -> die $ show $ "missed block: " <+> pretty hx
                        Just blk -> LBS.putStr blk
 
-      let walkAnn :: Ann -> MTree [HashRef] -> IO ()
+      let walkAnn :: MTreeAnn [HashRef] -> IO ()
-          walkAnn ann t = do
+          walkAnn ann = do
-            bprocess :: Int -> ByteString -> IO ByteString <- case ann of
+            bprocess :: Hash HbSync -> ByteString -> IO ByteString <- case (_mtaCrypt ann) of
-              NullAnn -> pure (\_ -> pure)
+              NullEncryption -> pure (const pure)
-              GroupKeyCrypt crypth -> do
+              CryptAccessKeyNaClAsymm crypth -> do
-                  mblk <- getBlock ss crypth
-                  case mblk of
-                    Nothing  -> die $ show $ "missed block: " <+> pretty crypth
-                    Just blk -> do
-                        -- FIXME apply crypto scheme from `crypth` to stream of blk's
-                        -- extract AccessKeyV1 from blk
-                        -- find in it any pubkey known to us
-                        -- decrypt corresponding EncryptedBox
-                        -- get actual (PrivKey 'Encrypt e) to use for merkle decryption
-                        pure $ \blnum blk -> do
-                            -- convert blnum to Crypto.Saltine.Core.Box.Nonce
-                            -- decrypt blk with this nonce and priv key
-                            undefined
 
-            flip evalStateT firstNumOfBlock $
+                  keyringFile <- pure (uniLastMay @OptKeyringFile opts <&> unOptKeyringFile)
-             walkMerkleTree t (lift . getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
+                      `orDie` "block encrypted. keyring required"
+                  s <- BS.readFile keyringFile
+                  ourKeys <- _peerKeyring
+                      <$> pure (parseCredentials @MerkleEncryptionType (AsCredFile s))
+                      `orDie` "bad keyring file"
+
+                  blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth)
+                  recipientKeys :: [(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)]
+                    <- pure ((either (const Nothing) Just . deserialiseOrFail) blkc)
+                      `orDie` "can not deserialise access key"
+
+                  (ourkr, box)
+                      <- pure (Monoid.getFirst
+                                (foldMap (\kr@(KeyringEntry pk sk _)
+                                           -> Monoid.First ((kr, )
+                                          <$> Map.lookup pk (Map.fromList recipientKeys)))
+                                         ourKeys))
+                      `orDie` "no available recipient key"
+
+                  kr <- pure (openEncryptedKey box ourkr)
+                      `orDie` "can not open sealed secret key with our key"
+
+                  pure $ \hx blk ->
+                      pure ((fmap LBS.fromStrict . Encrypt.boxSealOpen (_krPk kr) (_krSk kr) . LBS.toStrict) blk)
+                      `orDie` (show $ "can not decode block: " <+> pretty hx)
+
+            walkMerkleTree (_mtaTree ann) (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
               case hr of
-                Left hx -> lift $ void $ hPrint stderr $ "missed block:" <+> pretty hx
+                Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx
                 Right (hrr :: [HashRef]) -> do
                   forM_ hrr $ \(HashRef hx) -> do
                     if honly then do
-                      lift $ print $ pretty hx
+                      print $ pretty hx
                     else do
-                      mblk <- lift $ getBlock ss hx
+                      blk <- getBlock ss hx `orDie` (show $ "missed block: " <+> pretty hx)
-                      case mblk of
+                      LBS.putStr =<< bprocess hx blk
-                        Nothing  -> lift $ die $ show $ "missed block: " <+> pretty hx
-                        Just blk -> do
-                            blnum <- get
-                            modify (+1)
-                            lift $ LBS.putStr =<< bprocess blnum blk
 
       case q of
         Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr
         Merkle h -> walk h
-        MerkleAnn (MTreeAnn ann hs) -> walkAnn ann hs
+        MerkleAnn ann -> walkAnn ann
         AnnRef h -> do
           let lnk = deserialise @AnnotatedHashRef obj
           let mbHead =  headMay [ h
@@ -190,9 +206,6 @@ runStore opts ss | justInit = do
   where
     justInit = maybe False fromOptInit (uniLastMay @OptInit opts)
 
-firstNumOfBlock :: Int
-firstNumOfBlock = 1
-
 runStore opts ss = do
 
   let fname = uniLastMay @OptInputFile opts
@@ -204,32 +217,39 @@ runStore opts ss = do
         root <- putAsMerkle ss handle
         print $ "merkle-root: " <+> pretty root
     Just encOpts -> do
+        gk :: GroupKey MerkleEncryptionType 'NaClAsymm
+            <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (encoptGroupkeyFile encOpts))
+            `orDie` "bad groupkey file"
 
-        -- FIXME generate AccessKeyV1, store it
         accKeyh <- maybe (die "can not store access key") pure
-              =<< (putBlock ss . serialise) do
+              =<< (putBlock ss . serialise @[(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)])
-            AccessKeyV1 (undefined :: [(PubKey 'Encrypt e, EncryptedBox)])
+              =<< (permittedPubKeys gk `forM` \pk -> (pk, ) <$> mkEncryptedKey (encryptionKey gk) pk)
 
         let rawChunks :: S.Stream (S.Of ByteString) IO ()
             rawChunks = readChunked handle (fromIntegral defBlockSize) -- FIXME: to settings!
 
             encryptedChunks :: S.Stream (S.Of ByteString) IO ()
-            -- FIXME get keys to enrypt
             encryptedChunks = rawChunks
-                & S.zip (S.enumFrom firstNumOfBlock)
+                & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal ((_krPk . encryptionKey) gk) . LBS.toStrict)
-                & S.map (\(blnum, blk) -> do
-                      -- FIXME convert blnum to Crypto.Saltine.Core.Box.Nonce
-                      -- encrypt blk with this nonce and priv key
-                      undefined
 
         mhash <- putAsMerkle ss encryptedChunks
+        mtree <- ((deserialise =<<) <$> getBlock ss (fromMerkleHash mhash))
+            `orDie` "merkle tree was not stored properly with `putAsMerkle`"
 
         mannh <- maybe (die "can not store MerkleAnn") pure
-              =<< (putBlock ss . serialise) do
+              =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do
-            MerkleAnn (MTreeAnn (GroupKeyCrypt accKeyh) (undefined mhash))
+            MTreeAnn NoMetaData (CryptAccessKeyNaClAsymm accKeyh) mtree
 
         print $ "merkle-ann-root: " <+> pretty mannh
 
+runNewGroupkey :: FilePath -> IO ()
+runNewGroupkey pubkeysFile = do
+  s <- BS.readFile pubkeysFile
+  pubkeys <- pure (parsePubKeys s) `orDie` "bad pubkeys file"
+  keypair <- newKeypair @MerkleEncryptionType Nothing
+  print $ pretty $ AsGroupKeyFile $ AsBase58
+      $ GroupKeyNaClAsymm keypair pubkeys
+
 runNewRef :: Data opts => opts -> MerkleHash -> SimpleStorage HbSync -> IO ()
 runNewRef opts mhash ss = do
   uuid <- UUID.nextRandom <&> (hashObject @HbSync . UUID.toASCIIBytes)
@@ -312,6 +332,7 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "keyring-key-add"  (info pKeyAdd (progDesc "adds a new keypair into the keyring"))
                         <> command "keyring-key-del"  (info pKeyDel (progDesc "removes a keypair from the keyring"))
                         <> command "show-peer-key"    (info pShowPeerKey (progDesc "show peer key from credential file"))
+                        <> command "groupkey-new"      (info pNewGroupkey (progDesc "generates a new groupkey"))
                         )
 
     common = do
@@ -328,16 +349,25 @@ main = join . customExecParser (prefs showHelpOnError) $
       o <- common
       file <- optional $ strArgument ( metavar "FILE" )
       init <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit
-      -- FIXME option to encrypt
+      groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" )
-      encOps :: Maybe (OptEncryption MerkleEncryptionType) <- optional $ undefined
+      encoptKeyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" )
-      pure $ withStore o (runStore ( StoreOpts init file encOps ))
+      encoptFromPubKey <- optional $ strOption ( metavar "PUB-KEY-BAS58" )
+      pure do
+          let encOps :: Maybe (OptEncryption MerkleEncryptionType)
+              encOps = groupkeyFile <&> \encoptGroupkeyFile -> OptEncryption{..}
+          withStore o (runStore ( StoreOpts init file encOps ))
 
     pCat = do
       o <- common
       hash  <- optional $ strArgument ( metavar "HASH" )
       onlyh <- optional $ flag' True ( short 'H' <> long "hashes-only" <> help "list only block hashes" )
       keyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" )
-      pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) keyringFile
+      pure $ withStore o $ runCat
+          $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile)
+
+    pNewGroupkey = do
+      pubkeysFile <- strArgument ( metavar "FILE" <> help "path to a file with a list of recipient public keys" )
+      pure $ runNewGroupkey pubkeysFile
 
     pHash = do
       o <- common

hbs2/hbs2.cabal

@@ -49,6 +49,7 @@ common shared-properties
                      , MultiParamTypeClasses
                      , OverloadedStrings
                      , QuasiQuotes
+                     , RecordWildCards
                      , ScopedTypeVariables
                      , StandaloneDeriving
                      , TupleSections
@@ -81,6 +82,7 @@ executable hbs2
                     , optparse-applicative
                     , prettyprinter
                     , safe
+                    , saltine
                     , serialise
                     , streaming
                     , text