write-encrypted-merkle.hs

instance ( MonadIO m
         , MonadError OperationError m
         , Storage sto h ByteString m
         , Storage sto h ByteString IO
         , h ~ HbSync
         , ForGroupKeySymm s
         ) => MerkleWriter (ToEncrypt 'Symm s ByteString) h sto m where

  type instance ToBlockW (ToEncrypt 'Symm s ByteString) = ByteString

  writeAsMerkle sto source = do

    let gk = toEncryptGroupKey source

    let key = toEncryptSecret source

    gkh <- writeAsMerkle sto (serialise gk) <&> HashRef

    let prk = HKDF.extractSkip @_ @HbSyncHash (Saltine.encode key)

    hashes' <- liftIO $ toEncryptData source

                & S.mapM ( \bs -> do
                             let (BA.SipHash w64) = BA.sipHash (BA.SipKey 11940070621075034887 442907749530188102) (LBS.toStrict bs)
                             let hbs = N.bytestring64 w64
                             let key0 = HKDF.expand prk hbs typicalKeyLength & Saltine.decode & fromJust
                             let nonceS = BS.take typicalNonceLength (hbs <> BS.replicate typicalNonceLength 0)
                             let nonce = Saltine.decode nonceS & fromJust
                             let encrypted = SK.secretbox key0 nonce (LBS.toStrict bs)
                             pure $ serialise (hbs, encrypted)
                         )

                & S.mapM (enqueueBlock sto)
                & S.map (fmap HashRef)
                & S.toList_

    let hashes = catMaybes hashes'

--     -- FIXME: handle-hardcode
    let pt = toPTree (MaxSize 256) (MaxNum 256) hashes -- FIXME: settings

    -- FIXME: this-might-not-be-true
    result <- runWriterT $ makeMerkle 0 pt $ \(_,mt,bss) -> do
      void $ lift $ putBlock sto bss
      tell [mt]

    let root = headMay (snd result)

    tree <- maybe (throwError StorageError) pure root

    let ann = MTreeAnn NoMetaData (EncryptGroupNaClSymm (fromHashRef gkh)) tree

    putBlock sto (serialise ann) >>= maybe (throwError StorageError) pure