{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Tahoe.CHK.URIExtension ( URIExtension (..), uriExtensionToBytes, showBytes, pURIExtension, ) where import Control.Applicative.Combinators (count) import Control.Applicative.Permutations (runPermutation, toPermutation) import Control.Monad (join, void) import Data.TreeDiff.Class (ToExpr) import Data.Void (Void) import GHC.Generics (Generic) import Text.Megaparsec ( MonadParsec (takeP), Parsec, anySingle, ) import Text.Megaparsec.Byte (string) import Text.Megaparsec.Byte.Lexer (decimal) import Data.ByteString.Base32 ( encodeBase32Unpadded, ) import qualified Data.ByteString as B import qualified Data.Text as T import Data.Text.Encoding ( decodeLatin1, encodeUtf8, ) import Data.List ( sort, ) import qualified Tahoe.CHK.Parsing import Tahoe.CHK.Types ( CrypttextHash, Parameters (..), Required, SegmentNum, Size, Total, ) import Tahoe.Netstring ( netstring, ) -- | Represent additional metadata that appears at the end of each share. data URIExtension = URIExtension { -- | The name of the encoding function. Only "zfec" is implemented. uriExtCodecName :: B.ByteString , -- | The parameters for the encoding function for all except the final -- segment. uriExtCodecParams :: Parameters , -- | The parameters for the encoding function for the final segment. uriExtTailCodecParams :: Parameters , -- | The application data size in bytes. uriExtSize :: Size , -- | The individual segment size in bytes. uriExtSegmentSize :: Size , -- | The number of segments of application data. Note the last segment -- may be short so it is not necessarily the case that uriExtSize == -- uriExtSegmentSize * uriExtNumSegments. uriExtNumSegments :: SegmentNum , -- | The required (K) parameter to the encoding function. This is a -- duplicate of the values in uriExtCodecParams and uriExtTailCodecParams. uriExtNeededShares :: Required , -- | The total (N) parameter to the encoding function. This too is a -- duplicate. uriExtTotalShares :: Total , -- | A tagged sha256d hash of the complete ciphertext. uriExtCrypttextHash :: CrypttextHash , -- | The root hash of a merkle tree where the leaf hashes are of segments of ciphertext. uriExtCrypttextRootHash :: CrypttextHash , -- | The root hash of a merkle tree where leaf hashes are the root hashes of all of the block hash trees. uriExtShareRootHash :: CrypttextHash } deriving (Eq, Ord, Generic, ToExpr) instance Show URIExtension where show (URIExtension name params tailParams size segSize numSegs needed total hash1 hash2 hash3) = T.unpack . T.concat $ [ "URIExtension { " , "codec = " , decodeLatin1 name , "; codec-params = " , showText params , "; tail-codec-params = " , showText tailParams , "; size = " , showText size , "; segment-size = " , showText segSize , "; num-segments = " , showText numSegs , "; needed-shares = " , showText needed , "; total-shares = " , showText total , "; crypttext-hash = " , showText $ b32 hash1 , "; crypttext-root-hash = " , showText $ b32 hash2 , "; share-root-hash = " , showText $ b32 hash3 , " }" ] where showText :: Show s => s -> T.Text showText = T.pack . show b32 = encodeBase32Unpadded -- Serialize a URIExtension to bytes in the format it appears in a CHK share. uriExtensionToBytes :: URIExtension -> B.ByteString uriExtensionToBytes = toWeirdString -- all of the below values are authenticated by the capability you get when you store data in Tahoe [ ("codec_name", uriExtCodecName) , ("codec_params", paramsToBytes . uriExtCodecParams) , ("tail_codec_params", paramsToBytes . uriExtTailCodecParams) , ("size", showBytes . uriExtSize) , ("segment_size", showBytes . uriExtSegmentSize) , ("num_segments", showBytes . uriExtNumSegments) , ("needed_shares", showBytes . uriExtNeededShares) , ("total_shares", showBytes . uriExtTotalShares) , ("crypttext_hash", uriExtCrypttextHash) -- hash of the *entire* cipher text , ("crypttext_root_hash", uriExtCrypttextRootHash) -- root hash of the *cipher text* merkle tree , ("share_root_hash", uriExtShareRootHash) -- root hash of the *share* merkle tree ] type Parser = Parsec Void B.ByteString -- | A version of bounded specialized to parsing bytestrings. bounded :: (Ord n, Integral n) => n -> n -> Parser n bounded = Tahoe.CHK.Parsing.bounded decimal {- | Parse the representation of a URIExtension which appears in CHK shares back into a URIExtension. -} pURIExtension :: Parser URIExtension pURIExtension = runPermutation $ URIExtension <$> toPermutation (B.pack <$> pField "codec_name" (`count` anySingle)) <*> toPermutation (pField "codec_params" $ const pParameters) <*> toPermutation (pField "tail_codec_params" $ const pParameters) <*> toPermutation (pField "size" $ const decimal) <*> toPermutation (pField "segment_size" $ const decimal) <*> toPermutation (pField "num_segments" $ const (bounded 1 maxBound)) <*> toPermutation (pField "needed_shares" $ const (bounded 1 256)) <*> toPermutation (pField "total_shares" $ const (bounded 1 256)) <*> toPermutation (pField "crypttext_hash" $ takeP Nothing) <*> toPermutation (pField "crypttext_root_hash" $ takeP Nothing) <*> toPermutation (pField "share_root_hash" $ takeP Nothing) -- | Parse one field of a serialized URIExtension. pField :: -- | The serialized label for the field. B.ByteString -> -- | A function that takes the length of the field value and returns a parser for the field value. (Int -> Parser a) -> -- | A parser for the field. Parser a pField label pInner = do void $ string (label <> ":") len <- decimal -- XXX Could overflow void $ string ":" result <- pInner len void $ string "," pure result -- | Serialize some named URIExtension fields to bytes. toWeirdString :: -- | A list of pairs of field names and functions to get serialized -- field values. [(B.ByteString, URIExtension -> B.ByteString)] -> -- | The URIExtension to get the field values from. URIExtension -> -- | The concatenation of all of the serialized fields. B.ByteString toWeirdString fields ext = B.concat . join . sort $ map (encodedField ext) fields where encodedField ext' (name, extract) = [name, ":", netstring (extract ext')] -- | Show a value as a UTF-8-encoded byte string. showBytes :: (Show s) => s -> B.ByteString showBytes = encodeUtf8 . T.pack . show {- | Serialize Parameters to a byte string in the format it appears within the URI extension block in a CHK share. -} paramsToBytes :: Parameters -> B.ByteString paramsToBytes Parameters{paramSegmentSize, paramTotalShares, paramRequiredShares} = B.concat [showBytes paramSegmentSize, "-", showBytes paramRequiredShares, "-", showBytes paramTotalShares] {- | Parse a serialized Parameters value in the format produced by paramsToBytes. -} pParameters :: Parser Parameters pParameters = (\segSize required total -> Parameters{paramSegmentSize = segSize, paramRequiredShares = required, paramHappyShares = 1, paramTotalShares = total}) <$> decimal <* string "-" <*> bounded 1 maxShares <* string "-" <*> bounded 1 maxShares where maxShares = 256