mirror of https://github.com/voidlizard/hbs2
134 lines
3.9 KiB
Haskell
134 lines
3.9 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
{-# Language UndecidableInstances #-}
|
|
{-# Language FunctionalDependencies #-}
|
|
module HBS2.Merkle.MetaData where
|
|
|
|
import HBS2.Prelude
|
|
import HBS2.OrDie
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Merkle
|
|
import HBS2.Hash
|
|
import HBS2.Storage
|
|
import HBS2.Data.Types.SmallEncryptedBlock
|
|
import HBS2.Net.Auth.GroupKeySymm as G
|
|
import HBS2.Storage.Operations.Class
|
|
import HBS2.Storage.Operations.ByteString (readChunkedBS)
|
|
|
|
import Data.Coerce
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Data.ByteString qualified as BS
|
|
import Codec.Serialise
|
|
import Data.Text.Encoding qualified as TE
|
|
import Control.Exception
|
|
import Control.Monad.Except
|
|
import Control.Monad.Trans.Maybe
|
|
|
|
-- import UnliftIO
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
extractMetaData :: forall s m . (MonadIO m, ForGroupKeySymm s, MonadError OperationError m)
|
|
|
|
=> (GroupKey 'Symm s -> m (Maybe GroupSecret))
|
|
-> AnyStorage
|
|
-> HashRef
|
|
-> m Text
|
|
extractMetaData fk sto hash = do
|
|
|
|
headBlock <- getBlock sto (coerce hash)
|
|
>>= orThrowError MissedBlockError
|
|
<&> deserialiseOrFail @(MTreeAnn [HashRef])
|
|
>>= orThrowError UnsupportedFormat
|
|
|
|
case headBlock of
|
|
MTreeAnn { _mtaMeta = ShortMetadata s } -> do
|
|
pure s
|
|
|
|
MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do
|
|
getBlock sto h
|
|
>>= orThrowError MissedBlockError
|
|
<&> LBS.toStrict
|
|
<&> TE.decodeUtf8
|
|
|
|
MTreeAnn { _mtaMeta = AnnHashRef h } -> do
|
|
getBlock sto h
|
|
>>= orThrowError MissedBlockError
|
|
<&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
|
|
>>= orThrowError UnsupportedFormat
|
|
>>= G.decryptBlock @_ @s sto fk
|
|
>>= \case
|
|
ShortMetadata s -> pure s
|
|
_ -> throwError UnsupportedFormat
|
|
|
|
_ -> throwError UnsupportedFormat
|
|
|
|
|
|
loadGroupKeyForTree :: ( ForGroupKeySymm s
|
|
, MonadIO m
|
|
)
|
|
=> AnyStorage
|
|
-> HashRef
|
|
-> m (Maybe (GroupKey 'Symm s))
|
|
|
|
loadGroupKeyForTree sto h = do
|
|
|
|
runMaybeT do
|
|
|
|
headBlock <- getBlock sto (fromHashRef h)
|
|
>>= toMPlus
|
|
<&> deserialiseOrFail @(MTreeAnn [HashRef])
|
|
>>= toMPlus
|
|
|
|
gkh <- case _mtaCrypt headBlock of
|
|
(EncryptGroupNaClSymm h1 _) -> pure (HashRef h1)
|
|
_ -> mzero
|
|
|
|
G.loadGroupKeyMaybe sto gkh >>= toMPlus
|
|
|
|
class ForGroupKeySymm s => ForEncryptedTree s a | a -> s where
|
|
getNonce :: Monad m => a -> m BS.ByteString
|
|
|
|
getContent :: a -> ByteString
|
|
getMetaData :: a -> Text
|
|
|
|
getBlockSize :: a -> Int
|
|
getBlockSize _ = 256 * 1024
|
|
|
|
data DefaultEncryptedTreeSource (s :: CryptoScheme) = DefSource Text LBS.ByteString
|
|
|
|
instance ForGroupKeySymm s => ForEncryptedTree s (DefaultEncryptedTreeSource s) where
|
|
getContent (DefSource _ lbs) = lbs
|
|
|
|
getMetaData (DefSource m _) = m
|
|
|
|
getNonce (DefSource _ lbs) = do
|
|
let s0 = LBS.take ( 1024 * 1024 ) lbs
|
|
let (HbSyncHash nonce) = hashObject @HbSync s0
|
|
pure nonce
|
|
|
|
createEncryptedTree :: forall s a m . ( ForEncryptedTree s a, MonadIO m )
|
|
=> AnyStorage
|
|
-> GroupSecret
|
|
-> GroupKey 'Symm s
|
|
-> a
|
|
-> m HashRef
|
|
createEncryptedTree sto gks gk what = do
|
|
|
|
|
|
nonce <- getNonce @s what
|
|
let lbs = getContent @s what
|
|
|
|
let segments = readChunkedBS lbs (getBlockSize what)
|
|
|
|
seb <- encryptBlock sto gks (Right gk) (Just nonce) (ShortMetadata (getMetaData @s what))
|
|
|
|
hmeta <- putBlock sto (serialise seb)
|
|
>>= orThrow StorageError
|
|
|
|
let source = ToEncryptSymmBS gks (Right gk) nonce segments (AnnHashRef hmeta) Nothing
|
|
|
|
runExceptT (writeAsMerkle sto source <&> HashRef) >>= orThrowPassIO
|
|
|
|
|