Skip to content
Snippets Groups Projects
Encoding.hs 5.19 KiB
Newer Older
  • Learn to ignore specific revisions
  • module Tahoe.SDMF.Internal.Encoding where
    
    
    import Control.Monad.IO.Class (MonadIO (liftIO))
    import Crypto.Cipher.AES128 (AESKey128, BlockCipher (buildKey))
    import Crypto.Classes (getIVIO)
    
    import qualified Crypto.PubKey.RSA.Types as RSA
    
    import Crypto.Types (IV)
    import Data.Bifunctor (Bifunctor (bimap))
    import qualified Data.ByteString as B
    
    import qualified Data.ByteString.Lazy as LB
    import qualified Data.Text as T
    import Data.Word (Word16, Word64, Word8)
    
    import Tahoe.CHK (padCiphertext, zfec, zunfec)
    import Tahoe.CHK.Crypto (taggedHash)
    import Tahoe.CHK.Encrypt (encrypt)
    import Tahoe.CHK.Merkle (MerkleTree (MerkleLeaf))
    import Tahoe.SDMF.Internal.Capability (Reader (..), Writer (..), deriveReader)
    import Tahoe.SDMF.Internal.Share (HashChain (HashChain), Share (..), signatureKeyToBytes, verificationKeyToBytes)
    
    
    {- | Given a pre-determined key pair and sequence number, encode some
     ciphertext into a collection of SDMF shares.
    
     A key pair *unique identifies* a "slot" (the storage location for the shares).
     Thus they cannot be re-used for "different" data.  Any shares created with a
     given key pair are part of the same logical data object.
    -}
    
    encode :: (MonadFail m, MonadIO m) => RSA.KeyPair -> Word64 -> Word16 -> Word16 -> LB.ByteString -> m ([Share], Writer)
    encode keypair shareSequenceNumber required total ciphertext = do
    
        blocks <- liftIO $ fmap LB.fromStrict <$> zfec (fromIntegral required) (fromIntegral total) (LB.toStrict $ padCiphertext required ciphertext)
    
    
        -- XXX Secure enough random source?
        iv <- liftIO (getIVIO :: IO (IV AESKey128))
    
        -- XXX fromIntegral is going from Word16 to Word8, not safe
    
        let makeShare' =
                flip $
                    makeShare
                        shareSequenceNumber
                        iv
                        (fromIntegral required)
                        (fromIntegral total)
                        (fromIntegral $ LB.length ciphertext)
                        (RSA.toPublicKey keypair)
    
        let makeShare'' = makeShare' <$> blocks
    
            resultE :: Either T.Text [Share]
            resultE = (traverse . flip fmap) encryptedPrivateKey makeShare''
    
        either (fail . T.unpack) pure ((,) <$> resultE <*> cap)
    
      where
        -- We can compute a capability immediately.
        cap = capabilityForKeyPair keypair
        encryptedPrivateKey = flip encryptPrivateKey (RSA.toPrivateKey keypair) <$> (writerWriteKey <$> cap)
    
    encryptPrivateKey :: AESKey128 -> RSA.PrivateKey -> B.ByteString
    
    encryptPrivateKey writeKey = LB.toStrict . encrypt writeKey . LB.fromStrict . signatureKeyToBytes
    
    
    makeShare ::
        Word64 ->
        IV AESKey128 ->
        Word8 ->
        Word8 ->
        Word64 ->
        RSA.PublicKey ->
        B.ByteString ->
        LB.ByteString ->
        Share
    makeShare shareSequenceNumber shareIV shareRequiredShares shareTotalShares shareSegmentSize shareVerificationKey shareEncryptedPrivateKey shareData = Share{..}
      where
        shareRootHash = B.replicate 32 0
        shareDataLength = fromIntegral $ LB.length shareData -- XXX Partial
        shareSignature = B.replicate 32 0 -- XXX Actually compute sig, and is it 32 bytes?
        shareHashChain = HashChain []
        shareBlockHashTree = MerkleLeaf (B.replicate 32 0) -- XXX Real hash here, plus length check
    
    decode :: (MonadFail m, MonadIO m) => Reader -> [(Word16, Share)] -> m LB.ByteString
    decode _ [] = fail "Cannot decode with no shares"
    decode _ s@((_, Share{shareRequiredShares, shareTotalShares, shareSegmentSize}) : shares)
        | length shares < fromIntegral shareRequiredShares = fail $ "got " <> show (length shares) <> " shares, required " <> show shareRequiredShares
        | otherwise = do
            ciphertext <- liftIO $ zunfec (fromIntegral shareRequiredShares) (fromIntegral shareTotalShares) (take (fromIntegral shareRequiredShares) blocks)
            pure . LB.take (fromIntegral shareSegmentSize) . LB.fromStrict $ ciphertext
      where
        blocks = bimap fromIntegral (LB.toStrict . shareData) <$> s
    
    -- | Compute an SDMF write capability for a given keypair.
    
    capabilityForKeyPair :: RSA.KeyPair -> Either T.Text Writer
    
    capabilityForKeyPair keypair =
        Writer <$> writerWriteKey <*> writerReader
      where
    
        writerWriteKey = maybeToEither "Failed to derive write key" . deriveWriteKey . RSA.toPrivateKey $ keypair
    
        verificationKeyHash = hashVerificationKey . RSA.toPublicKey $ keypair
        writerReader = deriveReader <$> writerWriteKey <*> pure verificationKeyHash
    
    
    maybeToEither :: a -> Maybe b -> Either a b
    maybeToEither a Nothing = Left a
    maybeToEither _ (Just b) = Right b
    
    
    {- | The tag used when hashing the signature key to the write key for the
     creation of an SDMF capability.
    -}
    mutableWriteKeyTag :: B.ByteString
    mutableWriteKeyTag = "allmydata_mutable_privkey_to_writekey_v1"
    
    writeKeyLength :: Int
    writeKeyLength = 16
    
    {- | Compute the verification key hash of the given verification key for
     inclusion in an SDMF share.
    -}
    hashVerificationKey :: RSA.PublicKey -> B.ByteString
    hashVerificationKey = taggedHash verificationKeyHashLength mutableVerificationKeyHashTag . verificationKeyToBytes
    
    verificationKeyHashLength :: Int
    verificationKeyHashLength = 32
    
    {- | The tag used when hashing the verification key to the verification key
     hash for inclusion in SDMF shares.
    -}
    mutableVerificationKeyHashTag :: B.ByteString
    mutableVerificationKeyHashTag = "allmydata_mutable_pubkey_to_fingerprint_v1"