packages feed

openpgp 0.3 → 0.4

raw patch · 95 files changed

+1664/−809 lines, 95 filesdep +HUnitdep +QuickCheckdep +quickcheck-instancesdep −Cryptodep −containersbinary-added

Dependencies added: HUnit, QuickCheck, quickcheck-instances, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependencies removed: Crypto, containers

Files

− Data/BaseConvert.hs 
@@ -1,30 +0,0 @@-module Data.BaseConvert (toString, toNum, toAlphaDigit, fromAlphaDigit) where--import Data.Sequence-import Data.Foldable (toList)-import Data.List-import Data.Char--digit_alphabet :: [Char]-digit_alphabet = ['0'..'9'] ++ ['A'..]--toBase :: (Integral a) => a -> a -> [a]-toBase _ 0 = [0]-toBase b v = toList $-	unfoldl (\n -> if n == 0 then Nothing else Just (n `divMod` b)) v--toAlphaDigit :: (Integral a) => a -> Char-toAlphaDigit = (digit_alphabet !!) . fromIntegral--toString :: (Integral a) => a -> a -> String-toString b v = map toAlphaDigit (toBase b v)--fromAlphaDigit :: (Num a) => Char -> a-fromAlphaDigit v = fromIntegral n-	where Just n = elemIndex (toUpper v) digit_alphabet--fromBase :: (Num a) => a -> [a] -> a-fromBase b = foldl (\n k -> n * b + k) 0--toNum :: (Num a) => a -> String -> a-toNum b v = fromBase b (map fromAlphaDigit v)
Data/OpenPGP.hs view
@@ -1,587 +1,1131 @@--- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880>------ The recommended way to import this module is:------ > import qualified Data.OpenPGP as OpenPGP-module Data.OpenPGP (Message(..), Packet(..), SignatureSubpacket(..), HashAlgorithm(..), KeyAlgorithm(..), CompressionAlgorithm(..), MPI(..), fingerprint_material, signatures_and_data, signature_issuer, calculate_signature_trailer) where--import Control.Monad-import Data.Bits-import Data.Word-import Data.Map (Map, (!))-import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as LZ-import qualified Data.ByteString.Lazy.UTF8 as LZ (toString, fromString)--import Data.Binary-import Data.Binary.Get-import Data.Binary.Put-import qualified Codec.Compression.Zlib.Raw as Zip-import qualified Codec.Compression.Zlib as Zlib-import qualified Codec.Compression.BZip as BZip2--import qualified Data.BaseConvert as BaseConvert--data Packet =-	SignaturePacket {-		version::Word8,-		signature_type::Word8,-		key_algorithm::KeyAlgorithm,-		hash_algorithm::HashAlgorithm,-		hashed_subpackets::[SignatureSubpacket],-		unhashed_subpackets::[SignatureSubpacket],-		hash_head::Word16,-		signature::MPI,-		trailer::LZ.ByteString-	} |-	OnePassSignaturePacket {-		version::Word8,-		signature_type::Word8,-		hash_algorithm::HashAlgorithm,-		key_algorithm::KeyAlgorithm,-		key_id::String,-		nested::Word8-	} |-	PublicKeyPacket {-		version::Word8,-		timestamp::Word32,-		key_algorithm::KeyAlgorithm,-		key::Map Char MPI-	} |-	SecretKeyPacket {-		version::Word8,-		timestamp::Word32,-		key_algorithm::KeyAlgorithm,-		key::Map Char MPI,-		s2k_useage::Word8,-		symmetric_type::Word8,-		s2k_type::Word8,-		s2k_hash_algorithm::HashAlgorithm,-		s2k_salt::Word64,-		s2k_count::Word8,-		encrypted_data::LZ.ByteString,-		private_hash::LZ.ByteString-	} |-	CompressedDataPacket {-		compression_algorithm::CompressionAlgorithm,-		message::Message-	} |-	LiteralDataPacket {-		format::Char,-		filename::String,-		timestamp::Word32,-		content::LZ.ByteString-	} |-	UserIDPacket String-	deriving (Show, Read, Eq)--instance Binary Packet where-	put p = do-		-- First two bits are 1 for new packet format-		put ((tag .|. 0xC0) :: Word8)-		-- Use 5-octet lengths-		put (255 :: Word8)-		put ((fromIntegral $ LZ.length body) :: Word32)-		putLazyByteString body-		where (body, tag) = put_packet p-	get = do-		tag <- get :: Get Word8-		let (t, l) =-			if (tag .&. 64) /= 0 then-				(tag .&. 63, parse_new_length)-			else-				((tag `shiftR` 2) .&. 15, parse_old_length tag)-		len <- l-		-- This forces the whole packet to be consumed-		packet <- getLazyByteString (fromIntegral len)-		return $ runGet (parse_packet t) packet---- http://tools.ietf.org/html/rfc4880#section-4.2.2-parse_new_length :: Get Word32-parse_new_length = do-	len <- fmap fromIntegral (get :: Get Word8)-	case len of-		-- One octet length-		_ | len < 192 -> return len-		-- Two octet length-		_ | len > 191 && len < 224 -> do-			second <- fmap fromIntegral (get :: Get Word8)-			return $ ((len - 192) `shiftL` 8) + second + 192-		-- Five octet length-		255 -> get :: Get Word32-		-- TODO: Partial body lengths. 1 << (len & 0x1F)-		_ -> fail "Unsupported new packet length."---- http://tools.ietf.org/html/rfc4880#section-4.2.1-parse_old_length :: Word8 -> Get Word32-parse_old_length tag =-	case tag .&. 3 of-		-- One octet length-		0 -> fmap fromIntegral (get :: Get Word8)-		-- Two octet length-		1 -> fmap fromIntegral (get :: Get Word16)-		-- Four octet length-		2 -> get-		-- Indeterminate length-		3 -> fmap fromIntegral remaining-		-- Error-		_ -> fail "Unsupported old packet length."---- http://tools.ietf.org/html/rfc4880#section-5.5.2-public_key_fields :: KeyAlgorithm -> [Char]-public_key_fields RSA     = ['n', 'e']-public_key_fields RSA_E   = public_key_fields RSA-public_key_fields RSA_S   = public_key_fields RSA-public_key_fields ELGAMAL = ['p', 'g', 'y']-public_key_fields DSA     = ['p', 'q', 'g', 'y']-public_key_fields _       = undefined -- Nothing in the spec. Maybe empty---- http://tools.ietf.org/html/rfc4880#section-5.5.3-secret_key_fields :: KeyAlgorithm -> [Char]-secret_key_fields RSA     = ['d', 'p', 'q', 'u']-secret_key_fields RSA_E   = secret_key_fields RSA-secret_key_fields RSA_S   = secret_key_fields RSA-secret_key_fields ELGAMAL = ['x']-secret_key_fields DSA     = ['x']-secret_key_fields _       = undefined -- Nothing in the spec. Maybe empty---- Need this seperate for trailer calculation-signature_packet_start :: Packet -> LZ.ByteString-signature_packet_start (SignaturePacket {-	version = 4,-	signature_type = signature_type,-	key_algorithm = key_algorithm,-	hash_algorithm = hash_algorithm,-	hashed_subpackets = hashed_subpackets-}) =-	LZ.concat [-		encode (0x04 :: Word8),-		encode signature_type,-		encode key_algorithm,-		encode hash_algorithm,-		encode ((fromIntegral $ LZ.length hashed_subs) :: Word16),-		hashed_subs-	]-	where hashed_subs = LZ.concat $ map encode hashed_subpackets-signature_packet_start _ =-	error "Trying to get start of signature packet for non signature packet."---- The trailer is just the top of the body plus some crap-calculate_signature_trailer :: Packet -> LZ.ByteString-calculate_signature_trailer p =-	LZ.concat [-		signature_packet_start p,-		encode (0x04 :: Word8),-		encode (0xff :: Word8),-		encode (fromIntegral (LZ.length $ signature_packet_start p) :: Word32)-	]--put_packet :: (Num a) => Packet -> (LZ.ByteString, a)-put_packet (SignaturePacket { version = 4,-                              signature_type = signature_type,-                              key_algorithm = key_algorithm,-                              hash_algorithm = hash_algorithm,-                              hashed_subpackets = hashed_subpackets,-                              unhashed_subpackets = unhashed_subpackets,-                              hash_head = hash_head,-                              signature = signature }) =-	(LZ.concat [ LZ.singleton 4, encode signature_type,-	            encode key_algorithm, encode hash_algorithm,-	            encode (fromIntegral $ LZ.length hashed :: Word16),-	            hashed,-	            encode (fromIntegral $ LZ.length unhashed :: Word16),-	            unhashed,-	            encode hash_head, encode signature ], 2)-	where hashed   = LZ.concat $ map encode hashed_subpackets-	      unhashed = LZ.concat $ map encode unhashed_subpackets-put_packet (OnePassSignaturePacket { version = version,-                                     signature_type = signature_type,-                                     hash_algorithm = hash_algorithm,-                                     key_algorithm = key_algorithm,-                                     key_id = key_id,-                                     nested = nested }) =-	(LZ.concat [ encode version, encode signature_type,-	             encode hash_algorithm, encode key_algorithm,-	             encode (BaseConvert.toNum 16 key_id :: Word64),-	             encode nested ], 4)-put_packet (SecretKeyPacket { version = version, timestamp = timestamp,-                              key_algorithm = algorithm, key = key,-                              s2k_useage = s2k_useage,-                              symmetric_type = symmetric_type,-                              s2k_type = s2k_type,-                              s2k_hash_algorithm = s2k_hash_algo,-                              s2k_salt = s2k_salt,-                              encrypted_data = encrypted_data }) =-	(LZ.concat $ [p, encode s2k_useage] ++-	(if s2k_useage `elem` [255, 254] then-		-- TODO: if s2k_type == 3 reverse ugly bit manipulation-		[encode symmetric_type, encode s2k_type, encode s2k_hash_algo] ++-		if s2k_type `elem` [1, 3] then [encode s2k_salt] else []-	else []) ++-	(if s2k_useage > 0 then-		[encrypted_data]-	else s) ++-	(if s2k_useage == 254 then-		[LZ.replicate 20 0] -- TODO SHA1 Checksum-	else-		[encode (fromIntegral $-			LZ.foldl (\c i -> (c + fromIntegral i) `mod` 65536)-			(0::Integer) (LZ.concat s) :: Word16)]), 5)-	where-	p = fst (put_packet $-		PublicKeyPacket version timestamp algorithm key-		:: (LZ.ByteString, Integer)) -- Supress warning-	s = map (encode . (key !)) (secret_key_fields algorithm)-put_packet (PublicKeyPacket { version = 4, timestamp = timestamp,-                              key_algorithm = algorithm, key = key }) =-	(LZ.concat $ [LZ.singleton 4, encode timestamp, encode algorithm] ++-	            map (encode . (key !)) (public_key_fields algorithm), 6)-put_packet (CompressedDataPacket { compression_algorithm = algorithm,-                                   message = message }) =-	(LZ.append (encode algorithm) $ compress $ encode message, 8)-	where compress = case algorithm of-		Uncompressed -> id-		ZIP -> Zip.compress-		ZLIB -> Zlib.compress-		BZip2 -> BZip2.compress-put_packet (LiteralDataPacket { format = format, filename = filename,-                                timestamp = timestamp, content = content-                              }) =-	(LZ.concat [encode format, encode filename_l, lz_filename,-	            encode timestamp, content], 11)-	where-	filename_l  = (fromIntegral $ LZ.length lz_filename) :: Word8-	lz_filename = LZ.fromString filename-put_packet (UserIDPacket txt) = (LZ.fromString txt, 13)-put_packet _ = error "Unsupported Packet version or type in put_packet."--parse_packet :: Word8 -> Get Packet--- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2-parse_packet  2 = do-	version <- get-	case version of-		3 -> undefined -- TODO: V3 sigs-		4 -> do-			signature_type <- get-			key_algorithm <- get-			hash_algorithm <- get-			hashed_size <- fmap fromIntegral (get :: Get Word16)-			hashed_data <- getLazyByteString hashed_size-			let hashed = runGet get_signature_subpackets hashed_data-			unhashed_size <- fmap fromIntegral (get :: Get Word16)-			unhashed_data <- getLazyByteString unhashed_size-			let unhashed = runGet get_signature_subpackets unhashed_data-			hash_head <- get-			signature <- get-			return SignaturePacket {-				version = version,-				signature_type = signature_type,-				key_algorithm = key_algorithm,-				hash_algorithm = hash_algorithm,-				hashed_subpackets = hashed,-				unhashed_subpackets = unhashed,-				hash_head = hash_head,-				signature = signature,-				trailer = LZ.concat [encode version, encode signature_type, encode key_algorithm, encode hash_algorithm, encode (fromIntegral hashed_size :: Word16), hashed_data, LZ.pack [4, 0xff], encode ((6 + fromIntegral hashed_size) :: Word32)]-			}-		x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "."--- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4-parse_packet  4 = do-	version <- get-	signature_type <- get-	hash_algo <- get-	key_algo <- get-	key_id <- get :: Get Word64-	nested <- get-	return OnePassSignaturePacket {-		version = version,-		signature_type = signature_type,-		hash_algorithm = hash_algo,-		key_algorithm = key_algo,-		key_id = BaseConvert.toString 16 key_id,-		nested = nested-	}--- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3-parse_packet  5 = do-	-- Parse PublicKey part-	(PublicKeyPacket {-		version = version,-		timestamp = timestamp,-		key_algorithm = algorithm,-		key = key-	}) <- parse_packet 6-	s2k_useage <- get :: Get Word8-	let k = SecretKeyPacket version timestamp algorithm key s2k_useage-	k' <- case s2k_useage of-		_ | s2k_useage `elem` [255, 254] -> do-			symmetric_type <- get-			s2k_type <- get-			s2k_hash_algorithm <- get-			s2k_salt <- if s2k_type `elem` [1, 3] then get-				else return undefined-			s2k_count <- if s2k_type == 3 then do-				c <- fmap fromIntegral (get :: Get Word8)-				return $ fromIntegral $-					(16 + (c .&. 15)) `shiftL` ((c `shiftR` 4) + 6)-				else return undefined-			return (k symmetric_type s2k_type s2k_hash_algorithm-				s2k_salt s2k_count)-		_ | s2k_useage > 0 ->-			-- s2k_useage is symmetric_type in this case-			return (k s2k_useage undefined undefined undefined undefined)-		_ ->-			return (k undefined undefined undefined undefined undefined)-	if s2k_useage > 0 then do {-		encrypted <- getRemainingLazyByteString;-		return (k' encrypted undefined)-	} else do-		key <- foldM (\m f -> do-			mpi <- get :: Get MPI-			return $ Map.insert f mpi m) key (secret_key_fields algorithm)-		private_hash <- getRemainingLazyByteString-		return ((k' undefined private_hash) {key = key})--- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2-parse_packet  6 = do-	version <- get :: Get Word8-	case version of-		4 -> do-			timestamp <- get-			algorithm <- get-			key <- mapM (\f -> do-				mpi <- get :: Get MPI-				return (f, mpi)) (public_key_fields algorithm)-			return PublicKeyPacket {-				version = 4,-				timestamp = timestamp,-				key_algorithm = algorithm,-				key = Map.fromList key-			}-		x -> fail $ "Unsupported PublicKeyPacket version " ++ show x ++ "."--- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6-parse_packet  8 = do-	algorithm <- get-	message <- getRemainingLazyByteString-	let decompress = case algorithm of-		Uncompressed -> id-		ZIP -> Zip.decompress-		ZLIB -> Zlib.decompress-		BZip2 -> BZip2.decompress-	return CompressedDataPacket {-		compression_algorithm = algorithm,-		message = runGet (get :: Get Message) (decompress message)-	}--- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9-parse_packet 11 = do-	format <- get-	filenameLength <- get :: Get Word8-	filename <- getLazyByteString (fromIntegral filenameLength)-	timestamp <- get-	content <- getRemainingLazyByteString-	return LiteralDataPacket {-		format = format,-		filename = LZ.toString filename,-		timestamp = timestamp,-		content = content-	}--- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11-parse_packet 13 =-	fmap (UserIDPacket . LZ.toString) getRemainingLazyByteString--- Fail nicely for unimplemented packets-parse_packet x = fail $ "Unimplemented OpenPGP packet tag " ++ show x ++ "."---- | Helper method for fingerprints and such-fingerprint_material :: Packet -> [LZ.ByteString]-fingerprint_material (PublicKeyPacket {version = 4,-                      timestamp = timestamp,-                      key_algorithm = algorithm,-                      key = key}) =-	[-		LZ.singleton 0x99,-		encode (6 + fromIntegral (LZ.length material) :: Word16),-		LZ.singleton 4, encode timestamp, encode algorithm,-		material-	]-	where material = LZ.concat $-		map (\f -> encode (key ! f)) (public_key_fields algorithm)--- Proxy to make SecretKeyPacket work-fingerprint_material (SecretKeyPacket {version = 4,-                      timestamp = timestamp,-                      key_algorithm = algorithm,-                      key = key}) =-	fingerprint_material PublicKeyPacket {version = 4,-                      timestamp = timestamp,-                      key_algorithm = algorithm,-                      key = key}-fingerprint_material p | version p `elem` [2, 3] = [n, e]-	where n = LZ.drop 2 (encode (key p ! 'n'))-	      e = LZ.drop 2 (encode (key p ! 'e'))-fingerprint_material _ =-	error "Unsupported Packet version or type in fingerprint_material."--data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224-	deriving (Show, Read, Eq)-instance Binary HashAlgorithm where-	put MD5       = put (01 :: Word8)-	put SHA1      = put (02 :: Word8)-	put RIPEMD160 = put (03 :: Word8)-	put SHA256    = put (08 :: Word8)-	put SHA384    = put (09 :: Word8)-	put SHA512    = put (10 :: Word8)-	put SHA224    = put (11 :: Word8)-	get = do-		tag <- get :: Get Word8-		case tag of-			01 -> return MD5-			02 -> return SHA1-			03 -> return RIPEMD160-			08 -> return SHA256-			09 -> return SHA384-			10 -> return SHA512-			11 -> return SHA224-			x  -> fail $ "Unknown HashAlgorithm " ++ show x ++ "."--data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH-	deriving (Show, Read, Eq)-instance Binary KeyAlgorithm where-	put RSA     = put (01 :: Word8)-	put RSA_E   = put (02 :: Word8)-	put RSA_S   = put (03 :: Word8)-	put ELGAMAL = put (16 :: Word8)-	put DSA     = put (17 :: Word8)-	put ECC     = put (18 :: Word8)-	put ECDSA   = put (19 :: Word8)-	put DH      = put (21 :: Word8)-	get = do-		tag <- get :: Get Word8-		case tag of-			01 -> return RSA-			02 -> return RSA_E-			03 -> return RSA_S-			16 -> return ELGAMAL-			17 -> return DSA-			18 -> return ECC-			19 -> return ECDSA-			21 -> return DH-			x  -> fail $ "Unknown KeyAlgorithm " ++ show x ++ "."--data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2-	deriving (Show, Read, Eq)-instance Binary CompressionAlgorithm where-	put Uncompressed = put (0 :: Word8)-	put ZIP          = put (1 :: Word8)-	put ZLIB         = put (2 :: Word8)-	put BZip2        = put (3 :: Word8)-	get = do-		tag <- get :: Get Word8-		case tag of-			0 -> return Uncompressed-			1 -> return ZIP-			2 -> return ZLIB-			3 -> return BZip2-			x  -> fail $ "Unknown CompressionAlgorithm " ++ show x ++ "."---- A message is encoded as a list that takes the entire file-newtype Message = Message [Packet] deriving (Show, Read, Eq)-instance Binary Message where-	put (Message []) = return ()-	put (Message (x:xs)) = do-		put x-		put (Message xs)-	get = do-		done <- isEmpty-		if done then return (Message []) else do {-			next_packet <- get :: Get Packet;-			(Message tail) <- get :: Get Message;-			return (Message (next_packet:tail));-		}---- | Extract all signature and data packets from a 'Message'-signatures_and_data :: Message -> ([Packet], [Packet])-signatures_and_data (Message ((CompressedDataPacket {message = m}):_)) =-	signatures_and_data m-signatures_and_data (Message lst) =-	(filter isSig lst, filter isDta lst)-	where isSig (SignaturePacket {}) = True-	      isSig _ = False-	      isDta (LiteralDataPacket {}) = True-	      isDta _ = False--newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord)-instance Binary MPI where-	put (MPI i) = do-		put (((fromIntegral . LZ.length $ bytes) - 1) * 8-			+ floor (logBase (2::Double) $ fromIntegral (bytes `LZ.index` 0))-			+ 1 :: Word16)-		putLazyByteString bytes-		where bytes = LZ.reverse $ LZ.unfoldr (\x -> if x == 0 then Nothing-			else Just (fromIntegral x, x `shiftR` 8)) i-	get = do-		length <- fmap fromIntegral (get :: Get Word16)-		bytes <- getLazyByteString ((length + 7) `div` 8)-		return (MPI (LZ.foldl (\a b ->-			a `shiftL` 8 .|. fromIntegral b) 0 bytes))--data SignatureSubpacket =-	SignatureCreationTimePacket Word32 |-	IssuerPacket String-	deriving (Show, Read, Eq)--instance Binary SignatureSubpacket where-	put p = do-		-- Use 5-octet-length + 1 for tag as the first packet body octet-		put (255 :: Word8)-		put (fromIntegral (LZ.length body) + 1 :: Word32)-		put tag-		putLazyByteString body-		where (body, tag) = put_signature_subpacket p-	get = do-		len <- fmap fromIntegral (get :: Get Word8)-		len <- case len of-			_ | len > 190 && len < 255 -> do -- Two octet length-				second <- fmap fromIntegral (get :: Get Word8)-				return $ ((len - 192) `shiftR` 8) + second + 192-			255 -> -- Five octet length-				fmap fromIntegral (get :: Get Word32)-			_ -> -- One octet length, no furthur processing-				return len-		tag <- get :: Get Word8-		-- This forces the whole packet to be consumed-		packet <- getLazyByteString (len-1)-		return $ runGet (parse_signature_subpacket tag) packet---- | Find the keyid that issued a SignaturePacket-signature_issuer :: Packet -> Maybe String-signature_issuer (SignaturePacket {hashed_subpackets = hashed,-                                   unhashed_subpackets = unhashed}) =-	if length issuers > 0 then Just issuer else Nothing-	where IssuerPacket issuer = issuers !! 0-	      issuers = filter isIssuer hashed ++ filter isIssuer unhashed-	      isIssuer (IssuerPacket {}) = True-	      isIssuer _ = False-signature_issuer _ = Nothing--put_signature_subpacket :: SignatureSubpacket -> (LZ.ByteString, Word8)-put_signature_subpacket (SignatureCreationTimePacket time) =-	(encode time, 2)-put_signature_subpacket (IssuerPacket keyid) =-	(encode (BaseConvert.toNum 16 keyid :: Word64), 16)--get_signature_subpackets :: Get [SignatureSubpacket]-get_signature_subpackets = do-	done <- isEmpty-	if done then return [] else do {-		next_packet <- get :: Get SignatureSubpacket;-		tail <- get_signature_subpackets;-		return (next_packet:tail);-	}--parse_signature_subpacket :: Word8 -> Get SignatureSubpacket--- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4-parse_signature_subpacket  2 = fmap SignatureCreationTimePacket get--- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5-parse_signature_subpacket 16 = do-	keyid <- get :: Get Word64-	return $ IssuerPacket (BaseConvert.toString 16 keyid)--- Fail nicely for unimplemented packets-parse_signature_subpacket x =-	fail $ "Unimplemented OpenPGP signature subpacket tag " ++ show x ++ "."+{-# LANGUAGE CPP #-}+-- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880>+--+-- The recommended way to import this module is:+--+-- > import qualified Data.OpenPGP as OpenPGP+module Data.OpenPGP (+	Packet(+		OnePassSignaturePacket,+		PublicKeyPacket,+		SecretKeyPacket,+		CompressedDataPacket,+		MarkerPacket,+		LiteralDataPacket,+		UserIDPacket,+		ModificationDetectionCodePacket,+		UnsupportedPacket,+		compression_algorithm,+		content,+		encrypted_data,+		filename,+		format,+		hash_algorithm,+		hashed_subpackets,+		hash_head,+		key,+		is_subkey,+		v3_days_of_validity,+		key_algorithm,+		key_id,+		message,+		nested,+		private_hash,+		s2k_count,+		s2k_hash_algorithm,+		s2k_salt,+		s2k_type,+		s2k_useage,+		signature,+		signature_type,+		symmetric_type,+		timestamp,+		trailer,+		unhashed_subpackets,+		version+	),+	isSignaturePacket,+	signaturePacket,+	Message(..),+	SignatureSubpacket(..),+	HashAlgorithm(..),+	KeyAlgorithm(..),+	SymmetricAlgorithm(..),+	CompressionAlgorithm(..),+	RevocationCode(..),+	MPI(..),+	find_key,+	fingerprint_material,+	signatures_and_data,+	signature_issuer+) where++import Numeric+import Control.Monad+import Control.Exception (assert)+import Data.Bits+import Data.Word+import Data.Char+import Data.Maybe+import Data.List+import Data.OpenPGP.Internal+import qualified Data.ByteString.Lazy as LZ++#ifdef CEREAL+import Data.Serialize+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as B (toString, fromString)+#define BINARY_CLASS Serialize+#else+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.UTF8 as B (toString, fromString)+#define BINARY_CLASS Binary+#endif++import qualified Codec.Compression.Zlib.Raw as Zip+import qualified Codec.Compression.Zlib as Zlib+import qualified Codec.Compression.BZip as BZip2++#ifdef CEREAL+getRemainingByteString :: Get B.ByteString+getRemainingByteString = remaining >>= getByteString++getSomeByteString :: Word64 -> Get B.ByteString+getSomeByteString = getByteString . fromIntegral++putSomeByteString :: B.ByteString -> Put+putSomeByteString = putByteString++unsafeRunGet :: Get a -> B.ByteString -> a+unsafeRunGet g bs = let Right v = runGet g bs in v++compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString+compress algo = toStrictBS . lazyCompress algo . toLazyBS++decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString+decompress algo = toStrictBS . lazyDecompress algo . toLazyBS++toStrictBS :: LZ.ByteString -> B.ByteString+toStrictBS = B.concat . LZ.toChunks++toLazyBS :: B.ByteString -> LZ.ByteString+toLazyBS = LZ.fromChunks . (:[])+#else+getRemainingByteString :: Get B.ByteString+getRemainingByteString = getRemainingLazyByteString++getSomeByteString :: Word64 -> Get B.ByteString+getSomeByteString = getLazyByteString . fromIntegral++putSomeByteString :: B.ByteString -> Put+putSomeByteString = putLazyByteString++unsafeRunGet :: Get a -> B.ByteString -> a+unsafeRunGet = runGet++compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString+compress = lazyCompress++decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString+decompress = lazyDecompress+#endif++lazyCompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString+lazyCompress Uncompressed = id+lazyCompress ZIP          = Zip.compress+lazyCompress ZLIB         = Zlib.compress+lazyCompress BZip2        = BZip2.compress+lazyCompress x            = error ("No implementation for " ++ show x)++lazyDecompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString+lazyDecompress Uncompressed = id+lazyDecompress ZIP          = Zip.decompress+lazyDecompress ZLIB         = Zlib.decompress+lazyDecompress BZip2        = BZip2.decompress+lazyDecompress x            = error ("No implementation for " ++ show x)++assertProp :: (a -> Bool) -> a -> a+assertProp f x = assert (f x) x++data Packet =+	SignaturePacket {+		version::Word8,+		signature_type::Word8,+		key_algorithm::KeyAlgorithm,+		hash_algorithm::HashAlgorithm,+		hashed_subpackets::[SignatureSubpacket],+		unhashed_subpackets::[SignatureSubpacket],+		hash_head::Word16,+		signature::[MPI],+		trailer::B.ByteString+	} |+	OnePassSignaturePacket {+		version::Word8,+		signature_type::Word8,+		hash_algorithm::HashAlgorithm,+		key_algorithm::KeyAlgorithm,+		key_id::String,+		nested::Word8+	} |+	PublicKeyPacket {+		version::Word8,+		timestamp::Word32,+		key_algorithm::KeyAlgorithm,+		key::[(Char,MPI)],+		is_subkey::Bool,+		v3_days_of_validity::Maybe Word16+	} |+	SecretKeyPacket {+		version::Word8,+		timestamp::Word32,+		key_algorithm::KeyAlgorithm,+		key::[(Char,MPI)],+		s2k_useage::Word8, -- determines if the Maybes are Just or Nothing+		symmetric_type::Maybe Word8,+		s2k_type::Maybe Word8,+		s2k_hash_algorithm::Maybe HashAlgorithm,+		s2k_salt::Maybe Word64,+		s2k_count::Maybe Word32,+		encrypted_data::B.ByteString,+		private_hash::Maybe B.ByteString, -- the hash may be in the encrypted data+		is_subkey::Bool+	} |+	CompressedDataPacket {+		compression_algorithm::CompressionAlgorithm,+		message::Message+	} |+	MarkerPacket |+	LiteralDataPacket {+		format::Char,+		filename::String,+		timestamp::Word32,+		content::B.ByteString+	} |+	UserIDPacket String |+	ModificationDetectionCodePacket B.ByteString |+	UnsupportedPacket Word8 B.ByteString+	deriving (Show, Read, Eq)++instance BINARY_CLASS Packet where+	put p = do+		-- First two bits are 1 for new packet format+		put ((tag .|. 0xC0) :: Word8)+		case tag of+			19 -> put (assertProp (<192) blen :: Word8)+			_  -> do+				-- Use 5-octet lengths+				put (255 :: Word8)+				put (blen :: Word32)+				putSomeByteString body+		where+		blen :: (Num a) => a+		blen = fromIntegral $ B.length body+		(body, tag) = put_packet p+	get = do+		tag <- get :: Get Word8+		let (t, l) =+			if (tag .&. 64) /= 0 then+				(tag .&. 63, parse_new_length)+			else+				((tag `shiftR` 2) .&. 15, parse_old_length tag)+		len <- l+		-- This forces the whole packet to be consumed+		packet <- getSomeByteString (fromIntegral len)+		return $ unsafeRunGet (parse_packet t) packet++-- http://tools.ietf.org/html/rfc4880#section-4.2.2+parse_new_length :: Get Word32+parse_new_length = do+	len <- fmap fromIntegral (get :: Get Word8)+	case len of+		-- One octet length+		_ | len < 192 -> return len+		-- Two octet length+		_ | len > 191 && len < 224 -> do+			second <- fmap fromIntegral (get :: Get Word8)+			return $ ((len - 192) `shiftL` 8) + second + 192+		-- Five octet length+		255 -> get :: Get Word32+		-- TODO: Partial body lengths. 1 << (len & 0x1F)+		_ -> fail "Unsupported new packet length."++-- http://tools.ietf.org/html/rfc4880#section-4.2.1+parse_old_length :: Word8 -> Get Word32+parse_old_length tag =+	case tag .&. 3 of+		-- One octet length+		0 -> fmap fromIntegral (get :: Get Word8)+		-- Two octet length+		1 -> fmap fromIntegral (get :: Get Word16)+		-- Four octet length+		2 -> get+		-- Indeterminate length+		3 -> fmap fromIntegral remaining+		-- Error+		_ -> fail "Unsupported old packet length."++-- http://tools.ietf.org/html/rfc4880#section-5.5.2+public_key_fields :: KeyAlgorithm -> [Char]+public_key_fields RSA     = ['n', 'e']+public_key_fields RSA_E   = public_key_fields RSA+public_key_fields RSA_S   = public_key_fields RSA+public_key_fields ELGAMAL = ['p', 'g', 'y']+public_key_fields DSA     = ['p', 'q', 'g', 'y']+public_key_fields _       = undefined -- Nothing in the spec. Maybe empty++-- http://tools.ietf.org/html/rfc4880#section-5.5.3+secret_key_fields :: KeyAlgorithm -> [Char]+secret_key_fields RSA     = ['d', 'p', 'q', 'u']+secret_key_fields RSA_E   = secret_key_fields RSA+secret_key_fields RSA_S   = secret_key_fields RSA+secret_key_fields ELGAMAL = ['x']+secret_key_fields DSA     = ['x']+secret_key_fields _       = undefined -- Nothing in the spec. Maybe empty++(!) :: (Eq k) => [(k,v)] -> k -> v+(!) xs = fromJust . (`lookup` xs)++-- Need this seperate for trailer calculation+signature_packet_start :: Packet -> B.ByteString+signature_packet_start (SignaturePacket {+	version = 4,+	signature_type = signature_type,+	key_algorithm = key_algorithm,+	hash_algorithm = hash_algorithm,+	hashed_subpackets = hashed_subpackets+}) =+	B.concat [+		encode (0x04 :: Word8),+		encode signature_type,+		encode key_algorithm,+		encode hash_algorithm,+		encode ((fromIntegral $ B.length hashed_subs) :: Word16),+		hashed_subs+	]+	where+	hashed_subs = B.concat $ map encode hashed_subpackets+signature_packet_start x =+	error ("Trying to get start of signature packet for: " ++ show x)++-- The trailer is just the top of the body plus some crap+calculate_signature_trailer :: Packet -> B.ByteString+calculate_signature_trailer (SignaturePacket { version = v,+                                               signature_type = signature_type,+                                               unhashed_subpackets = unhashed_subpackets+                                             }) | v `elem` [2,3] =+	B.concat [+		encode signature_type,+		encode creation_time+	]+	where+	Just (SignatureCreationTimePacket creation_time) = find isCreation unhashed_subpackets+	isCreation (SignatureCreationTimePacket {}) = True+	isCreation _ = False+calculate_signature_trailer p@(SignaturePacket {version = 4}) =+	B.concat [+		signature_packet_start p,+		encode (0x04 :: Word8),+		encode (0xff :: Word8),+		encode (fromIntegral (B.length $ signature_packet_start p) :: Word32)+	]+calculate_signature_trailer x =+	error ("Trying to calculate signature trailer for: " ++ show x)++put_packet :: (Num a) => Packet -> (B.ByteString, a)+put_packet (SignaturePacket { version = v,+                              unhashed_subpackets = unhashed_subpackets,+                              key_algorithm = key_algorithm,+                              hash_algorithm = hash_algorithm,+                              hash_head = hash_head,+                              signature = signature,+                              trailer = trailer }) | v `elem` [2,3] =+	-- TODO: Assert that there are no subpackets we cannot encode?+	(B.concat $ [+		B.singleton v,+		B.singleton 0x05,+		trailer, -- signature_type and creation_time+		encode keyid,+		encode key_algorithm,+		encode hash_algorithm,+		encode hash_head+	] ++ map encode signature, 2)+	where+	keyid = fst $ head $ readHex keyidS :: Word64+	Just (IssuerPacket keyidS) = find isIssuer unhashed_subpackets+	isIssuer (IssuerPacket {}) = True+	isIssuer _ = False+put_packet (SignaturePacket { version = 4,+                              unhashed_subpackets = unhashed_subpackets,+                              hash_head = hash_head,+                              signature = signature,+                              trailer = trailer }) =+	(B.concat $ [+		trailer_top,+		encode (fromIntegral $ B.length unhashed :: Word16),+		unhashed, encode hash_head+	] ++ map encode signature, 2)+	where+	trailer_top = B.reverse $ B.drop 6 $ B.reverse trailer+	unhashed = B.concat $ map encode unhashed_subpackets+put_packet (OnePassSignaturePacket { version = version,+                                     signature_type = signature_type,+                                     hash_algorithm = hash_algorithm,+                                     key_algorithm = key_algorithm,+                                     key_id = key_id,+                                     nested = nested }) =+	(B.concat [ encode version, encode signature_type,+	             encode hash_algorithm, encode key_algorithm,+	             encode (fst $ head $ readHex key_id :: Word64),+	             encode nested ], 4)+put_packet (SecretKeyPacket { version = version, timestamp = timestamp,+                              key_algorithm = algorithm, key = key,+                              s2k_useage = s2k_useage,+                              symmetric_type = symmetric_type,+                              s2k_type = s2k_type,+                              s2k_hash_algorithm = s2k_hash_algo,+                              s2k_salt = s2k_salt,+                              s2k_count = s2k_count,+                              encrypted_data = encrypted_data,+                              is_subkey = is_subkey }) =+	(B.concat $ [p, encode s2k_useage] +++	(if s2k_useage `elem` [255, 254] then+		[encode $ fromJust symmetric_type, encode s2k_t,+		 encode $ fromJust s2k_hash_algo] +++		(if s2k_t `elem` [1,3] then [encode $ fromJust s2k_salt] else []) +++		if s2k_t == 3 then+			[encode $ encode_s2k_count $ fromJust s2k_count] else []+	else []) +++	(if s2k_useage > 0 then+		[encrypted_data]+	else s +++		-- XXX: Checksum is part of encrypted_data for V4 ONLY+		if s2k_useage == 254 then+			[B.replicate 20 0] -- TODO SHA1 Checksum+		else+			[encode (fromIntegral $+				B.foldl (\c i -> (c + fromIntegral i) `mod` 65536)+				(0::Integer) (B.concat s) :: Word16)]),+	if is_subkey then 7 else 5)+	where+	(Just s2k_t) = s2k_type+	p = fst (put_packet $+		PublicKeyPacket version timestamp algorithm key False Nothing+		:: (B.ByteString, Integer)) -- Supress warning+	s = map (encode . (key !)) (secret_key_fields algorithm)+put_packet p@(PublicKeyPacket { version = v, timestamp = timestamp,+                              key_algorithm = algorithm, key = key,+                              is_subkey = is_subkey })+	| v == 3 =+		final (B.concat $ [+			B.singleton 3, encode timestamp,+			encode (fromJust $ v3_days_of_validity p),+			encode algorithm+		] ++ material)+	| v == 4 =+		final (B.concat $ [+			B.singleton 4, encode timestamp, encode algorithm+		] ++ material)+	where+	final x = (x, if is_subkey then 14 else 6)+	material = map (encode . (key !)) (public_key_fields algorithm)+put_packet (CompressedDataPacket { compression_algorithm = algorithm,+                                   message = message }) =+	(B.append (encode algorithm) $ compress algorithm $ encode message, 8)+put_packet MarkerPacket = (B.fromString "PGP", 10)+put_packet (LiteralDataPacket { format = format, filename = filename,+                                timestamp = timestamp, content = content+                              }) =+	(B.concat [encode format, encode filename_l, lz_filename,+	            encode timestamp, content], 11)+	where+	filename_l  = (fromIntegral $ B.length lz_filename) :: Word8+	lz_filename = B.fromString filename+put_packet (UserIDPacket txt) = (B.fromString txt, 13)+put_packet (ModificationDetectionCodePacket bstr) = (bstr, 19)+put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag)+put_packet x = error ("Unsupported Packet version or type in put_packet: " ++ show x)++parse_packet :: Word8 -> Get Packet+-- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2+parse_packet  2 = do+	version <- get+	case version of+		_ | version `elem` [2,3] -> do+			_ <- fmap (assertProp (==5)) (get :: Get Word8)+			signature_type <- get+			creation_time <- get :: Get Word32+			keyid <- get :: Get Word64+			key_algorithm <- get+			hash_algorithm <- get+			hash_head <- get+			signature <- listUntilEnd+			return SignaturePacket {+				version = version,+				signature_type = signature_type,+				key_algorithm = key_algorithm,+				hash_algorithm = hash_algorithm,+				hashed_subpackets = [],+				unhashed_subpackets = [+					SignatureCreationTimePacket creation_time,+					IssuerPacket $ pad $ map toUpper $ showHex keyid ""+				],+				hash_head = hash_head,+				signature = signature,+				trailer = B.concat [encode signature_type, encode creation_time]+			}+		4 -> do+			signature_type <- get+			key_algorithm <- get+			hash_algorithm <- get+			hashed_size <- fmap fromIntegral (get :: Get Word16)+			hashed_data <- getSomeByteString hashed_size+			let hashed = unsafeRunGet listUntilEnd hashed_data+			unhashed_size <- fmap fromIntegral (get :: Get Word16)+			unhashed_data <- getSomeByteString unhashed_size+			let unhashed = unsafeRunGet listUntilEnd unhashed_data+			hash_head <- get+			signature <- listUntilEnd+			return SignaturePacket {+				version = version,+				signature_type = signature_type,+				key_algorithm = key_algorithm,+				hash_algorithm = hash_algorithm,+				hashed_subpackets = hashed,+				unhashed_subpackets = unhashed,+				hash_head = hash_head,+				signature = signature,+				trailer = B.concat [encode version, encode signature_type, encode key_algorithm, encode hash_algorithm, encode (fromIntegral hashed_size :: Word16), hashed_data, B.pack [4, 0xff], encode ((6 + fromIntegral hashed_size) :: Word32)]+			}+		x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "."+	where+	pad s = replicate (16 - length s) '0' ++ s+-- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4+parse_packet  4 = do+	version <- get+	signature_type <- get+	hash_algo <- get+	key_algo <- get+	key_id <- get :: Get Word64+	nested <- get+	return OnePassSignaturePacket {+		version = version,+		signature_type = signature_type,+		hash_algorithm = hash_algo,+		key_algorithm = key_algo,+		key_id = pad $ map toUpper $ showHex key_id "",+		nested = nested+	}+	where+	pad s = replicate (16 - length s) '0' ++ s+-- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3+parse_packet  5 = do+	-- Parse PublicKey part+	(PublicKeyPacket {+		version = version,+		timestamp = timestamp,+		key_algorithm = algorithm,+		key = key+	}) <- parse_packet 6+	s2k_useage <- get :: Get Word8+	let k = SecretKeyPacket version timestamp algorithm key s2k_useage+	k' <- case s2k_useage of+		_ | s2k_useage `elem` [255, 254] -> do+			symmetric_type <- get+			s2k_type <- get+			s2k_hash_algorithm <- get+			s2k_salt <- if s2k_type `elem` [1, 3] then get+				else return undefined+			s2k_count <- if s2k_type == 3 then fmap decode_s2k_count get else+				return undefined+			return (k (Just symmetric_type) (Just s2k_type)+				(Just s2k_hash_algorithm) (Just s2k_salt) (Just s2k_count))+		_ | s2k_useage > 0 ->+			-- s2k_useage is symmetric_type in this case+			return (k (Just s2k_useage) Nothing Nothing Nothing Nothing)+		_ ->+			return (k Nothing Nothing Nothing Nothing Nothing)+	if s2k_useage > 0 then do {+		encrypted <- getRemainingByteString;+		return (k' encrypted Nothing False)+	} else do+		key <- foldM (\m f -> do+			mpi <- get :: Get MPI+			return $ (f,mpi):m) key (secret_key_fields algorithm)+		private_hash <- getRemainingByteString+		return ((k' B.empty (Just private_hash) False) {key = key})+-- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2+parse_packet  6 = do+	version <- get :: Get Word8+	case version of+		3 -> do+			timestamp <- get+			days <- get+			algorithm <- get+			key <- mapM (\f -> fmap ((,)f) get) (public_key_fields algorithm)+			return PublicKeyPacket {+				version = version,+				timestamp = timestamp,+				key_algorithm = algorithm,+				key = key,+				is_subkey = False,+				v3_days_of_validity = Just days+			}+		4 -> do+			timestamp <- get+			algorithm <- get+			key <- mapM (\f -> fmap ((,)f) get) (public_key_fields algorithm)+			return PublicKeyPacket {+				version = 4,+				timestamp = timestamp,+				key_algorithm = algorithm,+				key = key,+				is_subkey = False,+				v3_days_of_validity = Nothing+			}+		x -> fail $ "Unsupported PublicKeyPacket version " ++ show x ++ "."+-- Secret-SubKey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.4+parse_packet  7 = do+	p <- parse_packet 5+	return p {is_subkey = True}+-- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6+parse_packet  8 = do+	algorithm <- get+	message <- getRemainingByteString+	return CompressedDataPacket {+		compression_algorithm = algorithm,+		message = unsafeRunGet get (decompress algorithm message)+	}+-- MarkerPacket, http://tools.ietf.org/html/rfc4880#section-5.8+parse_packet 10 = return MarkerPacket+-- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9+parse_packet 11 = do+	format <- get+	filenameLength <- get :: Get Word8+	filename <- getSomeByteString (fromIntegral filenameLength)+	timestamp <- get+	content <- getRemainingByteString+	return LiteralDataPacket {+		format = format,+		filename = B.toString filename,+		timestamp = timestamp,+		content = content+	}+-- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11+parse_packet 13 =+	fmap (UserIDPacket . B.toString) getRemainingByteString+-- Public-Subkey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.2+parse_packet 14 = do+	p <- parse_packet 6+	return p {is_subkey = True}+-- ModificationDetectionCodePacket, http://tools.ietf.org/html/rfc4880#section-5.14+parse_packet 19 =+	fmap ModificationDetectionCodePacket getRemainingByteString+-- Represent unsupported packets as their tag and literal bytes+parse_packet tag = fmap (UnsupportedPacket tag) getRemainingByteString++-- | Helper method for fingerprints and such+fingerprint_material :: Packet -> [B.ByteString]+fingerprint_material p | version p == 4 =+	[+		B.singleton 0x99,+		encode (6 + fromIntegral (B.length material) :: Word16),+		B.singleton 4, encode (timestamp p), encode (key_algorithm p),+		material+	]+	where+	material = B.concat $ map (encode . (key p !))+		(public_key_fields $ key_algorithm p)+fingerprint_material p | version p `elem` [2, 3] = [n, e]+	where+	n = B.drop 2 (encode (key p ! 'n'))+	e = B.drop 2 (encode (key p ! 'e'))+fingerprint_material _ =+	error "Unsupported Packet version or type in fingerprint_material."++enum_to_word8 :: (Enum a) => a -> Word8+enum_to_word8 = fromIntegral . fromEnum++enum_from_word8 :: (Enum a) => Word8 -> a+enum_from_word8 = toEnum . fromIntegral++data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224 | HashAlgorithm Word8+	deriving (Show, Read, Eq)++instance Enum HashAlgorithm where+	toEnum 01 = MD5+	toEnum 02 = SHA1+	toEnum 03 = RIPEMD160+	toEnum 08 = SHA256+	toEnum 09 = SHA384+	toEnum 10 = SHA512+	toEnum 11 = SHA224+	toEnum x  = HashAlgorithm $ fromIntegral x+	fromEnum MD5       = 01+	fromEnum SHA1      = 02+	fromEnum RIPEMD160 = 03+	fromEnum SHA256    = 08+	fromEnum SHA384    = 09+	fromEnum SHA512    = 10+	fromEnum SHA224    = 11+	fromEnum (HashAlgorithm x) = fromIntegral x++instance BINARY_CLASS HashAlgorithm where+	put = put . enum_to_word8+	get = fmap enum_from_word8 get++data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH | KeyAlgorithm Word8+	deriving (Show, Read, Eq)++instance Enum KeyAlgorithm where+	toEnum 01 = RSA+	toEnum 02 = RSA_E+	toEnum 03 = RSA_S+	toEnum 16 = ELGAMAL+	toEnum 17 = DSA+	toEnum 18 = ECC+	toEnum 19 = ECDSA+	toEnum 21 = DH+	toEnum x  = KeyAlgorithm $ fromIntegral x+	fromEnum RSA     = 01+	fromEnum RSA_E   = 02+	fromEnum RSA_S   = 03+	fromEnum ELGAMAL = 16+	fromEnum DSA     = 17+	fromEnum ECC     = 18+	fromEnum ECDSA   = 19+	fromEnum DH      = 21+	fromEnum (KeyAlgorithm x) = fromIntegral x++instance BINARY_CLASS KeyAlgorithm where+	put = put . enum_to_word8+	get = fmap enum_from_word8 get++data SymmetricAlgorithm = Unencrypted | IDEA | TripleDES | CAST5 | Blowfish | AES128 | AES192 | AES256 | Twofish | SymmetricAlgorithm Word8+	deriving (Show, Read, Eq)++instance Enum SymmetricAlgorithm where+	toEnum 00 = Unencrypted+	toEnum 01 = IDEA+	toEnum 02 = TripleDES+	toEnum 03 = CAST5+	toEnum 04 = Blowfish+	toEnum 07 = AES128+	toEnum 08 = AES192+	toEnum 09 = AES256+	toEnum 10 = Twofish+	toEnum x  = SymmetricAlgorithm $ fromIntegral x+	fromEnum Unencrypted = 00+	fromEnum IDEA        = 01+	fromEnum TripleDES   = 02+	fromEnum CAST5       = 03+	fromEnum Blowfish    = 04+	fromEnum AES128      = 07+	fromEnum AES192      = 08+	fromEnum AES256      = 09+	fromEnum Twofish     = 10+	fromEnum (SymmetricAlgorithm x) = fromIntegral x++instance BINARY_CLASS SymmetricAlgorithm where+	put = put . enum_to_word8+	get = fmap enum_from_word8 get++data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | CompressionAlgorithm Word8+	deriving (Show, Read, Eq)++instance Enum CompressionAlgorithm where+	toEnum 0 = Uncompressed+	toEnum 1 = ZIP+	toEnum 2 = ZLIB+	toEnum 3 = BZip2+	toEnum x = CompressionAlgorithm $ fromIntegral x+	fromEnum Uncompressed = 0+	fromEnum ZIP          = 1+	fromEnum ZLIB         = 2+	fromEnum BZip2        = 3+	fromEnum (CompressionAlgorithm x) = fromIntegral x++instance BINARY_CLASS CompressionAlgorithm where+	put = put . enum_to_word8+	get = fmap enum_from_word8 get++data RevocationCode = NoReason | KeySuperseded | KeyCompromised | KeyRetired | UserIDInvalid | RevocationCode Word8 deriving (Show, Read, Eq)++instance Enum RevocationCode where+	toEnum 00 = NoReason+	toEnum 01 = KeySuperseded+	toEnum 02 = KeyCompromised+	toEnum 03 = KeyRetired+	toEnum 32 = UserIDInvalid+	toEnum  x = RevocationCode $ fromIntegral x+	fromEnum NoReason       = 00+	fromEnum KeySuperseded  = 01+	fromEnum KeyCompromised = 02+	fromEnum KeyRetired     = 03+	fromEnum UserIDInvalid  = 32+	fromEnum (RevocationCode x) = fromIntegral x++instance BINARY_CLASS RevocationCode where+	put = put . enum_to_word8+	get = fmap enum_from_word8 get++-- A message is encoded as a list that takes the entire file+newtype Message = Message [Packet] deriving (Show, Read, Eq)+instance BINARY_CLASS Message where+	put (Message xs) = mapM_ put xs+	get = fmap Message listUntilEnd++-- | Extract all signature and data packets from a 'Message'+signatures_and_data :: Message -> ([Packet], [Packet])+signatures_and_data (Message ((CompressedDataPacket {message = m}):_)) =+	signatures_and_data m+signatures_and_data (Message lst) =+	(filter isSignaturePacket lst, filter isDta lst)+	where+	isDta (LiteralDataPacket {}) = True+	isDta _ = False++newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord)+instance BINARY_CLASS MPI where+	put (MPI i) = do+		put (((fromIntegral . B.length $ bytes) - 1) * 8+			+ floor (logBase (2::Double) $ fromIntegral (bytes `B.index` 0))+			+ 1 :: Word16)+		putSomeByteString bytes+		where+		bytes = if B.null bytes' then B.singleton 0 else bytes'+		bytes' = B.reverse $ B.unfoldr (\x ->+				if x == 0 then Nothing else+					Just (fromIntegral x, x `shiftR` 8)+			) (assertProp (>=0) i)+	get = do+		length <- fmap fromIntegral (get :: Get Word16)+		bytes <- getSomeByteString ((length + 7) `div` 8)+		return (MPI (B.foldl (\a b ->+			a `shiftL` 8 .|. fromIntegral b) 0 bytes))++listUntilEnd :: (BINARY_CLASS a) => Get [a]+listUntilEnd = do+	done <- isEmpty+	if done then return [] else do+		next <- get+		rest <- listUntilEnd+		return (next:rest)++-- http://tools.ietf.org/html/rfc4880#section-5.2.3.1+data SignatureSubpacket =+	SignatureCreationTimePacket Word32 |+	SignatureExpirationTimePacket Word32 | -- seconds after CreationTime+	ExportableCertificationPacket Bool |+	TrustSignaturePacket {depth::Word8, trust::Word8} |+	RegularExpressionPacket String |+	RevocablePacket Bool |+	KeyExpirationTimePacket Word32 | -- seconds after key CreationTime+	PreferredSymmetricAlgorithmsPacket [SymmetricAlgorithm] |+	RevocationKeyPacket {+		sensitive::Bool,+		revocation_key_algorithm::KeyAlgorithm,+		revocation_key_fingerprint::String+	} |+	IssuerPacket String |+	NotationDataPacket {+		human_readable::Bool,+		notation_name::String,+		notation_value::String+	} |+	PreferredHashAlgorithmsPacket [HashAlgorithm] |+	PreferredCompressionAlgorithmsPacket [CompressionAlgorithm] |+	KeyServerPreferencesPacket {keyserver_no_modify::Bool} |+	PreferredKeyServerPacket String |+	PrimaryUserIDPacket Bool |+	PolicyURIPacket String |+	KeyFlagsPacket {+		certify_keys::Bool,+		sign_data::Bool,+		encrypt_communication::Bool,+		encrypt_storage::Bool,+		split_key::Bool,+		authentication::Bool,+		group_key::Bool+	} |+	SignerUserIDPacket String |+	ReasonForRevocationPacket RevocationCode String |+	FeaturesPacket {supports_mdc::Bool} |+	SignatureTargetPacket {+		target_key_algorithm::KeyAlgorithm,+		target_hash_algorithm::HashAlgorithm,+		hash::B.ByteString+	} |+	EmbeddedSignaturePacket Packet |+	UnsupportedSignatureSubpacket Word8 B.ByteString+	deriving (Show, Read, Eq)++instance BINARY_CLASS SignatureSubpacket where+	put p = do+		-- Use 5-octet-length + 1 for tag as the first packet body octet+		put (255 :: Word8)+		put (fromIntegral (B.length body) + 1 :: Word32)+		put tag+		putSomeByteString body+		where+		(body, tag) = put_signature_subpacket p+	get = do+		len <- fmap fromIntegral (get :: Get Word8)+		len <- case len of+			_ | len > 190 && len < 255 -> do -- Two octet length+				second <- fmap fromIntegral (get :: Get Word8)+				return $ ((len - 192) `shiftR` 8) + second + 192+			255 -> -- Five octet length+				fmap fromIntegral (get :: Get Word32)+			_ -> -- One octet length, no furthur processing+				return len+		tag <- fmap stripCrit get :: Get Word8+		-- This forces the whole packet to be consumed+		packet <- getSomeByteString (len-1)+		return $ unsafeRunGet (parse_signature_subpacket tag) packet+		where+		-- TODO: Decide how to actually encode the "is critical" data+		-- instead of just ignoring it+		stripCrit tag = if tag .&. 0x80 == 0x80 then tag .&. 0x7f else tag++put_signature_subpacket :: SignatureSubpacket -> (B.ByteString, Word8)+put_signature_subpacket (SignatureCreationTimePacket time) =+	(encode time, 2)+put_signature_subpacket (SignatureExpirationTimePacket time) =+	(encode time, 3)+put_signature_subpacket (ExportableCertificationPacket exportable) =+	(encode $ enum_to_word8 exportable, 4)+put_signature_subpacket (TrustSignaturePacket depth trust) =+	(B.concat [encode depth, encode trust], 5)+put_signature_subpacket (RegularExpressionPacket regex) =+	(B.concat [B.fromString regex, B.singleton 0], 6)+put_signature_subpacket (RevocablePacket exportable) =+	(encode $ enum_to_word8 exportable, 7)+put_signature_subpacket (KeyExpirationTimePacket time) =+	(encode time, 9)+put_signature_subpacket (PreferredSymmetricAlgorithmsPacket algos) =+	(B.concat $ map encode algos, 11)+put_signature_subpacket (RevocationKeyPacket sensitive kalgo fpr) =+	(B.concat [encode bitfield, encode kalgo, fprb], 12)+	where+	bitfield = 0x80 .|. (if sensitive then 0x40 else 0x0) :: Word8+	fprb = B.drop 2 $ encode (MPI fpri)+	fpri = fst $ head $ readHex fpr+put_signature_subpacket (IssuerPacket keyid) =+	(encode (fst $ head $ readHex keyid :: Word64), 16)+put_signature_subpacket (NotationDataPacket human_readable name value) =+	(B.concat [+		B.pack [flag1,0,0,0],+		encode (fromIntegral (B.length namebs) :: Word16),+		encode (fromIntegral (B.length valuebs) :: Word16),+		namebs,+		valuebs+	], 20)+	where+	valuebs = B.fromString value+	namebs = B.fromString name+	flag1 = if human_readable then 0x80 else 0x0+put_signature_subpacket (PreferredHashAlgorithmsPacket algos) =+	(B.concat $ map encode algos, 21)+put_signature_subpacket (PreferredCompressionAlgorithmsPacket algos) =+	(B.concat $ map encode algos, 22)+put_signature_subpacket (KeyServerPreferencesPacket no_modify) =+	(B.singleton (if no_modify then 0x80 else 0x0), 23)+put_signature_subpacket (PreferredKeyServerPacket uri) =+	(B.fromString uri, 24)+put_signature_subpacket (PrimaryUserIDPacket isprimary) =+	(encode $ enum_to_word8 isprimary, 25)+put_signature_subpacket (PolicyURIPacket uri) =+	(B.fromString uri, 26)+put_signature_subpacket (KeyFlagsPacket certify sign encryptC encryptS split auth group) =+	(B.singleton $+		flag 0x01 certify  .|.+		flag 0x02 sign     .|.+		flag 0x04 encryptC .|.+		flag 0x08 encryptS .|.+		flag 0x10 split    .|.+		flag 0x20 auth     .|.+		flag 0x80 group+	, 27)+	where+	flag x True = x+	flag _ False = 0x0+put_signature_subpacket (SignerUserIDPacket userid) =+	(B.fromString userid, 28)+put_signature_subpacket (ReasonForRevocationPacket code string) =+	(B.concat [encode code, B.fromString string], 29)+put_signature_subpacket (FeaturesPacket supports_mdc) =+	(B.singleton $ if supports_mdc then 0x01 else 0x00, 30)+put_signature_subpacket (SignatureTargetPacket kalgo halgo hash) =+	(B.concat [encode kalgo, encode halgo, hash], 31)+put_signature_subpacket (EmbeddedSignaturePacket packet) =+	(fst $ put_packet (assertProp isSignaturePacket packet), 32)+put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) =+	(bytes, tag)++parse_signature_subpacket :: Word8 -> Get SignatureSubpacket+-- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4+parse_signature_subpacket  2 = fmap SignatureCreationTimePacket get+-- SignatureExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.10+parse_signature_subpacket  3 = fmap SignatureExpirationTimePacket get+-- ExportableCertificationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.11+parse_signature_subpacket  4 =+	fmap (ExportableCertificationPacket . enum_from_word8) get+-- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.13+parse_signature_subpacket  5 = liftM2 TrustSignaturePacket get get+-- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.14+parse_signature_subpacket  6 = fmap+	(RegularExpressionPacket . B.toString . B.init) getRemainingByteString+-- RevocablePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.12+parse_signature_subpacket  7 =+	fmap (RevocablePacket . enum_from_word8) get+-- KeyExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.6+parse_signature_subpacket  9 = fmap KeyExpirationTimePacket get+-- PreferredSymmetricAlgorithms, http://tools.ietf.org/html/rfc4880#section-5.2.3.7+parse_signature_subpacket 11 =+	fmap PreferredSymmetricAlgorithmsPacket listUntilEnd+-- RevocationKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.15+parse_signature_subpacket 12 = do+	bitfield <- get :: Get Word8+	kalgo <- get+	fpr <- getSomeByteString 20+	-- bitfield must have bit 0x80 set, says the spec+	return RevocationKeyPacket {+		sensitive = bitfield .&. 0x40 == 0x40,+		revocation_key_algorithm = kalgo,+		revocation_key_fingerprint =+			pad $ map toUpper $ foldr (padB `oo` showHex) "" (B.unpack fpr)+	}+	where+	oo = (.) . (.)+	padB s | odd $ length s = '0':s+	       | otherwise = s+	pad s = replicate (40 - length s) '0' ++ s+-- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5+parse_signature_subpacket 16 = do+	keyid <- get :: Get Word64+	return $ IssuerPacket (pad $ map toUpper $ showHex keyid "")+	where+	pad s = replicate (16 - length s) '0' ++ s+-- NotationDataPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.16+parse_signature_subpacket 20 = do+	(flag1,_,_,_) <- get4word8+	(m,n) <- liftM2 (,) get get :: Get (Word16,Word16)+	name <- fmap B.toString $ getSomeByteString $ fromIntegral m+	value <- fmap B.toString $ getSomeByteString $ fromIntegral n+	return NotationDataPacket {+		human_readable = flag1 .&. 0x80 == 0x80,+		notation_name = name,+		notation_value = value+	}+	where+	get4word8 :: Get (Word8,Word8,Word8,Word8)+	get4word8 = liftM4 (,,,) get get get get+-- PreferredHashAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.8+parse_signature_subpacket 21 =+	fmap PreferredHashAlgorithmsPacket listUntilEnd+-- PreferredCompressionAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.9+parse_signature_subpacket 22 =+	fmap PreferredCompressionAlgorithmsPacket listUntilEnd+-- KeyServerPreferencesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.17+parse_signature_subpacket 23 = do+	empty <- isEmpty+	flag1 <- if empty then return 0 else get :: Get Word8+	return KeyServerPreferencesPacket {+		keyserver_no_modify = flag1 .&. 0x80 == 0x80+	}+-- PreferredKeyServerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.18+parse_signature_subpacket 24 =+	fmap (PreferredKeyServerPacket . B.toString) getRemainingByteString+-- PrimaryUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.19+parse_signature_subpacket 25 =+	fmap (PrimaryUserIDPacket . enum_from_word8) get+-- PolicyURIPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.20+parse_signature_subpacket 26 =+	fmap (PolicyURIPacket . B.toString) getRemainingByteString+-- KeyFlagsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.21+parse_signature_subpacket 27 = do+	empty <- isEmpty+	flag1 <- if empty then return 0 else get :: Get Word8+	return KeyFlagsPacket {+		certify_keys          = flag1 .&. 0x01 == 0x01,+		sign_data             = flag1 .&. 0x02 == 0x02,+		encrypt_communication = flag1 .&. 0x04 == 0x04,+		encrypt_storage       = flag1 .&. 0x08 == 0x08,+		split_key             = flag1 .&. 0x10 == 0x10,+		authentication        = flag1 .&. 0x20 == 0x20,+		group_key             = flag1 .&. 0x80 == 0x80+	}+-- SignerUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.22+parse_signature_subpacket 28 =+	fmap (SignerUserIDPacket . B.toString) getRemainingByteString+-- ReasonForRevocationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.23+parse_signature_subpacket 29 = liftM2 ReasonForRevocationPacket get+	(fmap B.toString getRemainingByteString)+-- FeaturesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.24+parse_signature_subpacket 30 = do+	empty <- isEmpty+	flag1 <- if empty then return 0 else get :: Get Word8+	return FeaturesPacket {+		supports_mdc = flag1 .&. 0x01 == 0x01+	}+-- SignatureTargetPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.25+parse_signature_subpacket 31 =+	liftM3 SignatureTargetPacket get get getRemainingByteString+-- EmbeddedSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.26+parse_signature_subpacket 32 =+	fmap (EmbeddedSignaturePacket . forceSignature) (parse_packet 2)+	where+	forceSignature x@(SignaturePacket {}) = x+	forceSignature _ = error "EmbeddedSignature must contain signature"+-- Represent unsupported packets as their tag and literal bytes+parse_signature_subpacket tag =+	fmap (UnsupportedSignatureSubpacket tag) getRemainingByteString++-- | Find the keyid that issued a SignaturePacket+signature_issuer :: Packet -> Maybe String+signature_issuer (SignaturePacket {hashed_subpackets = hashed,+                                   unhashed_subpackets = unhashed}) =+	if length issuers > 0 then Just issuer else Nothing+	where IssuerPacket issuer = issuers !! 0+	      issuers = filter isIssuer hashed ++ filter isIssuer unhashed+	      isIssuer (IssuerPacket {}) = True+	      isIssuer _ = False+signature_issuer _ = Nothing++find_key :: (Packet -> String) -> Message -> String -> Maybe Packet+find_key fpr (Message (x@(PublicKeyPacket {}):xs)) keyid =+	find_key' fpr x xs keyid+find_key fpr (Message (x@(SecretKeyPacket {}):xs)) keyid =+	find_key' fpr x xs keyid+find_key fpr (Message (_:xs)) keyid =+	find_key fpr (Message xs) keyid+find_key _ _ _ = Nothing++find_key' :: (Packet -> String) -> Packet -> [Packet] -> String -> Maybe Packet+find_key' fpr x xs keyid+	| thisid == keyid = Just x+	| otherwise = find_key fpr (Message xs) keyid+	where+	thisid = reverse $ take (length keyid) (reverse (fpr x))++-- | SignaturePacket smart constructor+signaturePacket :: Word8 -> Word8 -> KeyAlgorithm -> HashAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> Word16 -> [MPI] -> Packet+signaturePacket version signature_type key_algorithm hash_algorithm hashed_subpackets unhashed_subpackets hash_head signature =+	let p = SignaturePacket {+		version = version,+		signature_type = signature_type,+		key_algorithm = key_algorithm,+		hash_algorithm = hash_algorithm,+		hashed_subpackets = hashed_subpackets,+		unhashed_subpackets = unhashed_subpackets,+		hash_head = hash_head,+		signature = signature,+		trailer = undefined+	} in p { trailer = calculate_signature_trailer p }++isSignaturePacket :: Packet -> Bool+isSignaturePacket (SignaturePacket {})  = True+isSignaturePacket _                     = False
+ Data/OpenPGP/Arbitrary.hs view
@@ -0,0 +1,232 @@+module Data.OpenPGP.Arbitrary where+import Data.OpenPGP+import Test.QuickCheck+import Test.QuickCheck.Instances+import Numeric+import Data.Char+import Data.Word++ +instance Arbitrary Packet where+        arbitrary+          = do x <- choose (0 :: Int, 9)+               case x of+                   0 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           x3 <- arbitrary+                           x4 <- resize 10 (listOf arbitrary)+                           x5 <- resize 10 (listOf arbitrary)+                           x6 <- arbitrary+                           x7 <- arbitrary+                           version <- choose (2 :: Word8, 4)+                           case version of+                                   4 ->+                                           return (signaturePacket 4 x1 x2 x3 x4 x5 x6 x7)+                                   _ -> do+                                           creation_time <- arbitrary+                                           keyid <- vectorOf 16 (elements (['0'..'9'] ++ ['A'..'F']))+                                           return (signaturePacket version x1 x2 x3 [] [SignatureCreationTimePacket creation_time, IssuerPacket keyid] x6 x7)+                   1 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           x3 <- arbitrary+                           x4 <- arbitrary+                           x5 <- arbitrary+                           x6 <- arbitrary+                           return (OnePassSignaturePacket x1 x2 x3 x4 x5 x6)+                   2 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           x3 <- arbitrary+                           x4 <- arbitrary+                           x5 <- arbitrary+                           x6 <- arbitrary+                           return (PublicKeyPacket x1 x2 x3 x4 x5 x6)+                   3 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           x3 <- arbitrary+                           x4 <- arbitrary+                           x5 <- arbitrary+                           x6 <- arbitrary+                           x7 <- arbitrary+                           x8 <- arbitrary+                           x9 <- arbitrary+                           x10 <- arbitrary+                           x11 <- arbitrary+                           x12 <- arbitrary+                           x13 <- arbitrary+                           return (SecretKeyPacket x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)+                   4 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           return (CompressedDataPacket x1 x2)+                   5 -> return MarkerPacket+                   6 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           x3 <- arbitrary+                           x4 <- arbitrary+                           return (LiteralDataPacket x1 x2 x3 x4)+                   7 -> do x1 <- arbitrary+                           return (UserIDPacket x1)+                   8 -> do x1 <- arbitrary+                           return (ModificationDetectionCodePacket x1)+                   9 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           return (UnsupportedPacket x1 x2)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++ +instance Arbitrary HashAlgorithm where+        arbitrary+          = do x <- choose (0 :: Int, 7)+               case x of+                   0 -> return MD5+                   1 -> return SHA1+                   2 -> return RIPEMD160+                   3 -> return SHA256+                   4 -> return SHA384+                   5 -> return SHA512+                   6 -> return SHA224+                   7 -> do x1 <- suchThat arbitrary (`notElem` [01,02,03,08,09,10,11])+                           return (HashAlgorithm x1)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++ +instance Arbitrary KeyAlgorithm where+        arbitrary+          = do x <- choose (0 :: Int, 8)+               case x of+                   0 -> return RSA+                   1 -> return RSA_E+                   2 -> return RSA_S+                   3 -> return ELGAMAL+                   4 -> return DSA+                   5 -> return ECC+                   6 -> return ECDSA+                   7 -> return DH+                   8 -> do x1 <- suchThat arbitrary (`notElem` [01,02,03,16,17,18,19,21])+                           return (KeyAlgorithm x1)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++ +instance Arbitrary SymmetricAlgorithm where+        arbitrary+          = do x <- choose (0 :: Int, 9)+               case x of+                   0 -> return Unencrypted+                   1 -> return IDEA+                   2 -> return TripleDES+                   3 -> return CAST5+                   4 -> return Blowfish+                   5 -> return AES128+                   6 -> return AES192+                   7 -> return AES256+                   8 -> return Twofish+                   9 -> do x1 <- suchThat arbitrary (`notElem` [00,01,02,03,04,07,08,09,10])+                           return (SymmetricAlgorithm x1)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++ +instance Arbitrary CompressionAlgorithm where+        arbitrary+          = do x <- choose (0 :: Int, 4)+               case x of+                   0 -> return Uncompressed+                   1 -> return ZIP+                   2 -> return ZLIB+                   3 -> return BZip2+                   4 -> do x1 <- suchThat arbitrary (`notElem` [0,1,2,3])+                           return (CompressionAlgorithm x1)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++ +instance Arbitrary RevocationCode where+        arbitrary+          = do x <- choose (0 :: Int, 5)+               case x of+                   0 -> return NoReason+                   1 -> return KeySuperseded+                   2 -> return KeyCompromised+                   3 -> return KeyRetired+                   4 -> return UserIDInvalid+                   5 -> do x1 <- suchThat arbitrary (`notElem` [00,01,02,03,32])+                           return (RevocationCode x1)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++ +instance Arbitrary Message where+        arbitrary+          = do x1 <- arbitrary+               return (Message x1)++ +instance Arbitrary MPI where+        arbitrary+          = do x1 <- suchThat arbitrary (>=0)+               return (MPI x1)++ +instance Arbitrary SignatureSubpacket where+        arbitrary+          = do x <- choose (0 :: Int, 23)+               case x of+                   0 -> do x1 <- arbitrary+                           return (SignatureCreationTimePacket x1)+                   1 -> do x1 <- arbitrary+                           return (SignatureExpirationTimePacket x1)+                   2 -> do x1 <- arbitrary+                           return (ExportableCertificationPacket x1)+                   3 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           return (TrustSignaturePacket x1 x2)+                   4 -> do x1 <- arbitrary+                           return (RegularExpressionPacket x1)+                   5 -> do x1 <- arbitrary+                           return (RevocablePacket x1)+                   6 -> do x1 <- arbitrary+                           return (KeyExpirationTimePacket x1)+                   7 -> do x1 <- arbitrary+                           return (PreferredSymmetricAlgorithmsPacket x1)+                   8 -> do x1 <- arbitrary+                           x2 <- arbitrary+                           x3 <- vectorOf 40 (elements (['0'..'9'] ++ ['A'..'F']))+                           return (RevocationKeyPacket x1 x2 x3)+                   9 -> do x1 <- vectorOf 16 (elements (['0'..'9'] ++ ['A'..'F']))+                           return (IssuerPacket x1)+                   10 -> do x1 <- arbitrary+                            x2 <- arbitrary+                            x3 <- arbitrary+                            return (NotationDataPacket x1 x2 x3)+                   11 -> do x1 <- arbitrary+                            return (PreferredHashAlgorithmsPacket x1)+                   12 -> do x1 <- arbitrary+                            return (PreferredCompressionAlgorithmsPacket x1)+                   13 -> do x1 <- arbitrary+                            return (KeyServerPreferencesPacket x1)+                   14 -> do x1 <- arbitrary+                            return (PreferredKeyServerPacket x1)+                   15 -> do x1 <- arbitrary+                            return (PrimaryUserIDPacket x1)+                   16 -> do x1 <- arbitrary+                            return (PolicyURIPacket x1)+                   17 -> do x1 <- arbitrary+                            x2 <- arbitrary+                            x3 <- arbitrary+                            x4 <- arbitrary+                            x5 <- arbitrary+                            x6 <- arbitrary+                            x7 <- arbitrary+                            return (KeyFlagsPacket x1 x2 x3 x4 x5 x6 x7)+                   18 -> do x1 <- arbitrary+                            return (SignerUserIDPacket x1)+                   19 -> do x1 <- arbitrary+                            x2 <- arbitrary+                            return (ReasonForRevocationPacket x1 x2)+                   20 -> do x1 <- arbitrary+                            return (FeaturesPacket x1)+                   21 -> do x1 <- arbitrary+                            x2 <- arbitrary+                            x3 <- arbitrary+                            return (SignatureTargetPacket x1 x2 x3)+                   22 -> do x1 <- suchThat arbitrary isSignaturePacket+                            return (EmbeddedSignaturePacket x1)+                   23 -> do x1 <- arbitrary+                            return (UnsupportedSignatureSubpacket 105 x1)+                   _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
− Data/OpenPGP/Crypto.hs 
@@ -1,173 +0,0 @@--- | This is a wrapper around <http://hackage.haskell.org/package/Crypto>--- that currently does fingerprint generation and signature verification.------ The recommended way to import this module is:------ > import qualified Data.OpenPGP.Crypto as OpenPGP-module Data.OpenPGP.Crypto (sign, verify, fingerprint) where--import Data.Word-import Data.List (find)-import Data.Map ((!))-import qualified Data.ByteString.Lazy as LZ-import qualified Data.ByteString.Lazy.UTF8 as LZ (fromString)--import Data.Binary-import Codec.Utils (fromOctets)-import qualified Codec.Encryption.RSA as RSA-import qualified Data.Digest.MD5 as MD5-import qualified Data.Digest.SHA1 as SHA1-import qualified Data.Digest.SHA256 as SHA256-import qualified Data.Digest.SHA384 as SHA384-import qualified Data.Digest.SHA512 as SHA512--import qualified Data.OpenPGP as OpenPGP-import qualified Data.BaseConvert as BaseConvert---- | Generate a key fingerprint from a PublicKeyPacket or SecretKeyPacket--- <http://tools.ietf.org/html/rfc4880#section-12.2>-fingerprint :: OpenPGP.Packet -> String-fingerprint p | OpenPGP.version p == 4 =-	BaseConvert.toString 16 $ SHA1.toInteger $ SHA1.hash $-		LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p))-fingerprint p | OpenPGP.version p `elem` [2, 3] =-	concatMap (BaseConvert.toString 16) $-		MD5.hash $ LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p))-fingerprint _ = error "Unsupported Packet version or type in fingerprint."--find_key :: OpenPGP.Message -> String -> Maybe OpenPGP.Packet-find_key (OpenPGP.Message (x@(OpenPGP.PublicKeyPacket {}):xs)) keyid =-	find_key_ x xs keyid-find_key (OpenPGP.Message (x@(OpenPGP.SecretKeyPacket {}):xs)) keyid =-	find_key_ x xs keyid-find_key _ _ = Nothing--find_key_ :: OpenPGP.Packet -> [OpenPGP.Packet] -> String -> Maybe OpenPGP.Packet-find_key_ x xs keyid =-	if thisid == keyid then Just x else find_key (OpenPGP.Message xs) keyid-	where thisid = reverse $-		take (length keyid) (reverse (fingerprint x))--keyfield_as_octets :: OpenPGP.Packet -> Char -> [Word8]-keyfield_as_octets k f =-	LZ.unpack $ LZ.drop 2 (encode (k' ! f))-	where k' = OpenPGP.key k---- http://tools.ietf.org/html/rfc3447#page-43-emsa_pkcs1_v1_5_hash_padding :: OpenPGP.HashAlgorithm -> [Word8]-emsa_pkcs1_v1_5_hash_padding OpenPGP.MD5 = [0x30, 0x20, 0x30, 0x0c, 0x06, 0x08, 0x2a, 0x86, 0x48, 0x86, 0xf7, 0x0d, 0x02, 0x05, 0x05, 0x00, 0x04, 0x10]-emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA1 = [0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14]-emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA256 = [0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20]-emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA384 = [0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30]-emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA512 = [0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40]-emsa_pkcs1_v1_5_hash_padding _ =-	error "Unsupported HashAlgorithm in emsa_pkcs1_v1_5_hash_padding."--hash :: OpenPGP.HashAlgorithm -> [Word8] -> [Word8]-hash OpenPGP.MD5 = MD5.hash-hash OpenPGP.SHA1 = reverse . drop 2 . LZ.unpack . encode . OpenPGP.MPI . SHA1.toInteger . SHA1.hash-hash OpenPGP.SHA256 = SHA256.hash-hash OpenPGP.SHA384 = SHA384.hash-hash OpenPGP.SHA512 = SHA512.hash-hash _ = error "Unsupported HashAlgorithm in hash."--emsa_pkcs1_v1_5_encode :: [Word8] -> Int -> OpenPGP.HashAlgorithm -> [Word8]-emsa_pkcs1_v1_5_encode m emLen algo =-	[0, 1] ++ replicate (emLen - length t - 3) 0xff ++ [0] ++ t-	where t = emsa_pkcs1_v1_5_hash_padding algo ++ hash algo m---- | Verify a message signature.  Only supports RSA keys for now.-verify :: OpenPGP.Message    -- ^ Keys that may have made the signature-          -> OpenPGP.Message -- ^ LiteralData message to verify-          -> Int             -- ^ Index of signature to verify (0th, 1st, etc)-          -> Bool-verify keys message sigidx =-	encoded == RSA.encrypt (n, e) raw_sig-	where-	raw_sig = LZ.unpack $ LZ.drop 2 $ encode (OpenPGP.signature sig)-	encoded = emsa_pkcs1_v1_5_encode signature_over-		(length n) (OpenPGP.hash_algorithm sig)-	signature_over = LZ.unpack $ dta `LZ.append` OpenPGP.trailer sig-	(n, e) = (keyfield_as_octets k 'n', keyfield_as_octets k 'e')-	Just k = find_key keys issuer-	Just issuer = OpenPGP.signature_issuer sig-	sig = sigs !! sigidx-	(sigs, (OpenPGP.LiteralDataPacket {OpenPGP.content = dta}):_) =-		OpenPGP.signatures_and_data message---- | Sign data or key/userID pair.  Only supports RSA keys for now.-sign :: OpenPGP.Message    -- ^ SecretKeys, one of which will be used-        -> OpenPGP.Message -- ^ Message containing data or key to sign, and optional signature packet-        -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use is signature-        -> String  -- ^ KeyID of key to choose or @[]@ for first-        -> Integer -- ^ Timestamp for signature (unless sig supplied)-        -> OpenPGP.Packet-sign keys message hsh keyid timestamp =-	sig {-		OpenPGP.signature = OpenPGP.MPI $ toNum final,-		OpenPGP.hash_head = toNum $ take 2 final-	}-	where-	-- toNum has explicit param so that it can remain polymorphic-	toNum l = fromOctets (256::Integer) l-	final   = dropWhile (==0) $ RSA.decrypt (n, d) encoded-	encoded = emsa_pkcs1_v1_5_encode dta (length n) hsh-	(n, d)  = (keyfield_as_octets k 'n', keyfield_as_octets k 'd')-	dta     = LZ.unpack $ case signOver of {-		OpenPGP.LiteralDataPacket {OpenPGP.content = c} -> c;-		_ -> LZ.concat $ OpenPGP.fingerprint_material signOver ++ [-			LZ.singleton 0xB4,-			encode (fromIntegral (length firstUserID) :: Word32),-			LZ.fromString firstUserID-		]-	} `LZ.append` OpenPGP.trailer sig-	-- Always force key and hash algorithm-	sig     = let s = (findSigOrDefault (find isSignature m)) {-		OpenPGP.key_algorithm = OpenPGP.RSA,-		OpenPGP.hash_algorithm = hsh-	} in s { OpenPGP.trailer = OpenPGP.calculate_signature_trailer s }--	-- Either a SignaturePacket was found, or we need to make one-	findSigOrDefault (Just s) = s-	findSigOrDefault Nothing  = OpenPGP.SignaturePacket {-		OpenPGP.version = 4,-		OpenPGP.key_algorithm = undefined,-		OpenPGP.hash_algorithm = undefined,-		OpenPGP.signature_type = defaultStype,-		OpenPGP.hashed_subpackets = [-			-- Do we really need to pass in timestamp just for the default?-			OpenPGP.SignatureCreationTimePacket $ fromIntegral timestamp,-			OpenPGP.IssuerPacket keyid'-		] ++ (case signOver of-			OpenPGP.LiteralDataPacket {} -> []-			_ -> [] -- TODO: OpenPGP.KeyFlagsPacket [0x01, 0x02]-		),-		OpenPGP.unhashed_subpackets = [],-		OpenPGP.signature = undefined,-		OpenPGP.trailer = undefined,-		OpenPGP.hash_head = undefined-	}--	keyid'  = reverse $ take 16 $ reverse $ fingerprint k-	Just k  = find_key keys keyid--	Just (OpenPGP.UserIDPacket firstUserID) = find isUserID m--	defaultStype = case signOver of-		OpenPGP.LiteralDataPacket {OpenPGP.format = f} ->-			if f == 'b' then 0x00 else 0x01-		_ -> 0x13--	Just signOver = find isSignable m-	OpenPGP.Message m = message--	isSignable (OpenPGP.LiteralDataPacket {}) = True-	isSignable (OpenPGP.PublicKeyPacket {})   = True-	isSignable (OpenPGP.SecretKeyPacket {})   = True-	isSignable _                              = False--	isSignature (OpenPGP.SignaturePacket {})  = True-	isSignature _                             = False--	isUserID (OpenPGP.UserIDPacket {})        = True-	isUserID _                                = False
+ Data/OpenPGP/Internal.hs view
@@ -0,0 +1,20 @@+module Data.OpenPGP.Internal where++import Data.Word+import Data.Bits++decode_s2k_count :: Word8 -> Word32+decode_s2k_count c =  (16 + (fromIntegral c .&. 15)) `shiftL`+	((fromIntegral c `shiftR` 4) + 6)++encode_s2k_count :: Word32 -> Word8+encode_s2k_count iterations+	| iterations >= 65011712 = 255+	| decode_s2k_count result < iterations = result+1+	| otherwise = result+	where+	result = fromIntegral $ (fromIntegral c `shiftL` 4) .|. (count - 16)+	(count, c) = encode_s2k_count' (iterations `shiftR` 6) (0::Word8)+	encode_s2k_count' count c+		| count < 32 = (count, c)+		| otherwise = encode_s2k_count' (count `shiftR` 1) (c+1)
README view
@@ -7,12 +7,10 @@ and then defines instances of Data.Binary for each to facilitate encoding/decoding. -There is also a wrapper around <http://hackage.haskell.org/package/Crypto>-that currently does fingerprint generation, signature generation, and-signature verification (for RSA keys only).+For performing cryptography, see+<http://hackage.haskell.org/openpgp-crypto-api> or+<http://hackage.haskell.org/openpgp-Crypto> -It is intended that you use qualified imports with this library.  If importing-both modules, something like this will do:+It is intended that you use qualified imports with this library.  > import qualified Data.OpenPGP as OpenPGP-> import qualified Data.OpenPGP.Crypto as OpenPGP
openpgp.cabal view
@@ -1,10 +1,10 @@ name:            openpgp-version:         0.3+version:         0.4 cabal-version:   >= 1.8 license:         OtherLicense license-file:    COPYING category:        Data-copyright:       © 2011 Stephen Paul Weber+copyright:       © 2011-2012 Stephen Paul Weber author:          Stephen Paul Weber <singpolyma@singpolyma.net> maintainer:      Stephen Paul Weber <singpolyma@singpolyma.net> stability:       experimental@@ -23,36 +23,140 @@         and then defines instances of Data.Binary for each to facilitate         encoding/decoding.         .-        There is also a wrapper around <http://hackage.haskell.org/package/Crypto>-        that currently does fingerprint generation, signature generation, and-        signature verification (for RSA keys only).+        For performing cryptography, see+        <http://hackage.haskell.org/openpgp-crypto-api> or+        <http://hackage.haskell.org/openpgp-Crypto>         .-        It is intended that you use qualified imports with this library.  If importing-        both modules, something like this will do:+        It is intended that you use qualified imports with this library.         .         > import qualified Data.OpenPGP as OpenPGP-        > import qualified Data.OpenPGP.Crypto as OpenPGP  extra-source-files:-        README+        README,+        tests/suite.hs,+        tests/data/000001-006.public_key,+        tests/data/000002-013.user_id,+        tests/data/000003-002.sig,+        tests/data/000004-012.ring_trust,+        tests/data/000005-002.sig,+        tests/data/000006-012.ring_trust,+        tests/data/000007-002.sig,+        tests/data/000008-012.ring_trust,+        tests/data/000009-002.sig,+        tests/data/000010-012.ring_trust,+        tests/data/000011-002.sig,+        tests/data/000012-012.ring_trust,+        tests/data/000013-014.public_subkey,+        tests/data/000014-002.sig,+        tests/data/000015-012.ring_trust,+        tests/data/000016-006.public_key,+        tests/data/000017-002.sig,+        tests/data/000018-012.ring_trust,+        tests/data/000019-013.user_id,+        tests/data/000020-002.sig,+        tests/data/000021-012.ring_trust,+        tests/data/000022-002.sig,+        tests/data/000023-012.ring_trust,+        tests/data/000024-014.public_subkey,+        tests/data/000025-002.sig,+        tests/data/000026-012.ring_trust,+        tests/data/000027-006.public_key,+        tests/data/000028-002.sig,+        tests/data/000029-012.ring_trust,+        tests/data/000030-013.user_id,+        tests/data/000031-002.sig,+        tests/data/000032-012.ring_trust,+        tests/data/000033-002.sig,+        tests/data/000034-012.ring_trust,+        tests/data/000035-006.public_key,+        tests/data/000036-013.user_id,+        tests/data/000037-002.sig,+        tests/data/000038-012.ring_trust,+        tests/data/000039-002.sig,+        tests/data/000040-012.ring_trust,+        tests/data/000041-017.attribute,+        tests/data/000042-002.sig,+        tests/data/000043-012.ring_trust,+        tests/data/000044-014.public_subkey,+        tests/data/000045-002.sig,+        tests/data/000046-012.ring_trust,+        tests/data/000047-005.secret_key,+        tests/data/000048-013.user_id,+        tests/data/000049-002.sig,+        tests/data/000050-012.ring_trust,+        tests/data/000051-007.secret_subkey,+        tests/data/000052-002.sig,+        tests/data/000053-012.ring_trust,+        tests/data/000054-005.secret_key,+        tests/data/000055-002.sig,+        tests/data/000056-012.ring_trust,+        tests/data/000057-013.user_id,+        tests/data/000058-002.sig,+        tests/data/000059-012.ring_trust,+        tests/data/000060-007.secret_subkey,+        tests/data/000061-002.sig,+        tests/data/000062-012.ring_trust,+        tests/data/000063-005.secret_key,+        tests/data/000064-002.sig,+        tests/data/000065-012.ring_trust,+        tests/data/000066-013.user_id,+        tests/data/000067-002.sig,+        tests/data/000068-012.ring_trust,+        tests/data/000069-005.secret_key,+        tests/data/000070-013.user_id,+        tests/data/000071-002.sig,+        tests/data/000072-012.ring_trust,+        tests/data/000073-017.attribute,+        tests/data/000074-002.sig,+        tests/data/000075-012.ring_trust,+        tests/data/000076-007.secret_subkey,+        tests/data/000077-002.sig,+        tests/data/000078-012.ring_trust,+        tests/data/compressedsig-bzip2.gpg,+        tests/data/compressedsig.gpg,+        tests/data/compressedsig-zlib.gpg,+        tests/data/onepass_sig,+        tests/data/pubring.gpg,+        tests/data/secring.gpg,+        tests/data/uncompressed-ops-dsa.gpg,+        tests/data/uncompressed-ops-dsa-sha384.txt.gpg,+        tests/data/uncompressed-ops-rsa.gpg  library         exposed-modules:                 Data.OpenPGP-                Data.OpenPGP.Crypto          other-modules:-                Data.BaseConvert+                Data.OpenPGP.Internal          build-depends:                 base == 4.*,-                containers,                 bytestring,                 utf8-string,                 binary,                 zlib,+                bzlib++test-suite tests+        type:       exitcode-stdio-1.0+        main-is:    tests/suite.hs++        other-modules:+                Data.OpenPGP.Arbitrary++        build-depends:+                base == 4.*,+                bytestring,+                utf8-string,+                binary,+                zlib,                 bzlib,-                Crypto+                HUnit,+                QuickCheck >= 2.4.1.1,+                quickcheck-instances,+                test-framework,+                test-framework-hunit,+                test-framework-quickcheck2  source-repository head         type:     git
+ tests/data/000001-006.public_key view

binary file changed (absent → 171 bytes)

+ tests/data/000002-013.user_id view
@@ -0,0 +1,1 @@+´$Test Key (RSA) <testkey@example.org>
+ tests/data/000003-002.sig view

binary file changed (absent → 113 bytes)

+ tests/data/000004-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000005-002.sig view

binary file changed (absent → 113 bytes)

+ tests/data/000006-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000007-002.sig view

binary file changed (absent → 220 bytes)

+ tests/data/000008-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000009-002.sig view

binary file changed (absent → 158 bytes)

+ tests/data/000010-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000011-002.sig view

binary file changed (absent → 96 bytes)

+ tests/data/000012-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000013-014.public_subkey view

binary file changed (absent → 171 bytes)

+ tests/data/000014-002.sig view

binary file changed (absent → 195 bytes)

+ tests/data/000015-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000016-006.public_key view

binary file changed (absent → 1201 bytes)

+ tests/data/000017-002.sig view

binary file changed (absent → 123 bytes)

+ tests/data/000018-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000019-013.user_id view
@@ -0,0 +1,1 @@+´$Test Key (DSA) <testkey@example.com>
+ tests/data/000020-002.sig view

binary file changed (absent → 130 bytes)

+ tests/data/000021-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000022-002.sig view

binary file changed (absent → 186 bytes)

+ tests/data/000023-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000024-014.public_subkey view

binary file changed (absent → 608 bytes)

+ tests/data/000025-002.sig view

binary file changed (absent → 105 bytes)

+ tests/data/000026-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000027-006.public_key view

binary file changed (absent → 421 bytes)

+ tests/data/000028-002.sig view

binary file changed (absent → 99 bytes)

+ tests/data/000029-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000030-013.user_id view
@@ -0,0 +1,1 @@+´+Test Key (DSA sign-only) <test@example.net>
+ tests/data/000031-002.sig view

binary file changed (absent → 132 bytes)

+ tests/data/000032-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000033-002.sig view

binary file changed (absent → 96 bytes)

+ tests/data/000034-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000035-006.public_key view

binary file changed (absent → 143 bytes)

+ tests/data/000036-013.user_id view
@@ -0,0 +1,1 @@+´.Test Key (RSA sign-only) <testkey@example.net>
+ tests/data/000037-002.sig view

binary file changed (absent → 192 bytes)

+ tests/data/000038-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000039-002.sig view

binary file changed (absent → 72 bytes)

+ tests/data/000040-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000041-017.attribute view

binary file changed (absent → 1761 bytes)

+ tests/data/000042-002.sig view

binary file changed (absent → 192 bytes)

+ tests/data/000043-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000044-014.public_subkey view

binary file changed (absent → 272 bytes)

+ tests/data/000045-002.sig view

binary file changed (absent → 161 bytes)

+ tests/data/000046-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000047-005.secret_key view

binary file changed (absent → 610 bytes)

+ tests/data/000048-013.user_id view
@@ -0,0 +1,1 @@+´$Test Key (RSA) <testkey@example.org>
+ tests/data/000049-002.sig view

binary file changed (absent → 220 bytes)

+ tests/data/000050-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000051-007.secret_subkey view

binary file changed (absent → 611 bytes)

+ tests/data/000052-002.sig view

binary file changed (absent → 195 bytes)

+ tests/data/000053-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000054-005.secret_key view

binary file changed (absent → 1275 bytes)

+ tests/data/000055-002.sig view

binary file changed (absent → 123 bytes)

+ tests/data/000056-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000057-013.user_id view
@@ -0,0 +1,1 @@+´$Test Key (DSA) <testkey@example.com>
+ tests/data/000058-002.sig view

binary file changed (absent → 130 bytes)

+ tests/data/000059-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000060-007.secret_subkey view

binary file changed (absent → 698 bytes)

+ tests/data/000061-002.sig view

binary file changed (absent → 104 bytes)

+ tests/data/000062-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000063-005.secret_key view

binary file changed (absent → 484 bytes)

+ tests/data/000064-002.sig view

binary file changed (absent → 99 bytes)

+ tests/data/000065-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000066-013.user_id view
@@ -0,0 +1,1 @@+´+Test Key (DSA sign-only) <test@example.net>
+ tests/data/000067-002.sig view

binary file changed (absent → 106 bytes)

+ tests/data/000068-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000069-005.secret_key view

binary file changed (absent → 513 bytes)

+ tests/data/000070-013.user_id view
@@ -0,0 +1,1 @@+´.Test Key (RSA sign-only) <testkey@example.net>
+ tests/data/000071-002.sig view

binary file changed (absent → 192 bytes)

+ tests/data/000072-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000073-017.attribute view

binary file changed (absent → 1761 bytes)

+ tests/data/000074-002.sig view

binary file changed (absent → 192 bytes)

+ tests/data/000075-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/000076-007.secret_subkey view

binary file changed (absent → 961 bytes)

+ tests/data/000077-002.sig view

binary file changed (absent → 161 bytes)

+ tests/data/000078-012.ring_trust view

binary file changed (absent → 4 bytes)

+ tests/data/compressedsig-bzip2.gpg view

binary file changed (absent → 442 bytes)

+ tests/data/compressedsig-zlib.gpg view

binary file changed (absent → 322 bytes)

+ tests/data/compressedsig.gpg view

binary file changed (absent → 324 bytes)

+ tests/data/onepass_sig view

binary file changed (absent → 15 bytes)

+ tests/data/pubring.gpg view

binary file changed (absent → 179272 bytes)

+ tests/data/secring.gpg view

binary file changed (absent → 9329 bytes)

+ tests/data/uncompressed-ops-dsa-sha384.txt.gpg view

binary file changed (absent → 150 bytes)

+ tests/data/uncompressed-ops-dsa.gpg view

binary file changed (absent → 150 bytes)

+ tests/data/uncompressed-ops-rsa.gpg view

binary file changed (absent → 236 bytes)

+ tests/suite.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE CPP #-}+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding (Test)++import Data.Word+import Data.OpenPGP.Arbitrary ()+import qualified Data.OpenPGP as OpenPGP+import qualified Data.OpenPGP.Internal as OpenPGP++#ifdef CEREAL+import Data.Serialize+import qualified Data.ByteString as B++decode' :: (Serialize a) => B.ByteString -> a+decode' x = let Right v = decode x in v+#else+import Data.Binary+import qualified Data.ByteString.Lazy as B++decode' :: (Binary a) => B.ByteString -> a+decode' = decode+#endif++testSerialization :: FilePath -> Assertion+testSerialization fp = do+	bs <- B.readFile $ "tests/data/" ++ fp+	nullShield "First" (decode' bs) (\firstpass ->+			nullShield "Second" (decode' $ encode firstpass) (+				assertEqual ("for " ++ fp) firstpass+			)+		)+	where+	nullShield pass (OpenPGP.Message []) _ =+		assertFailure $ pass ++ " pass of " ++ fp ++ " decoded to nothing."+	nullShield _ m f = f m++prop_s2k_count :: Word8 -> Bool+prop_s2k_count c =+	c == OpenPGP.encode_s2k_count (OpenPGP.decode_s2k_count c)++prop_MPI_serialization_loop :: OpenPGP.MPI -> Bool+prop_MPI_serialization_loop mpi =+	mpi == decode' (encode mpi)++prop_SignatureSubpacket_serialization_loop :: OpenPGP.SignatureSubpacket -> Bool+prop_SignatureSubpacket_serialization_loop packet =+	packet == decode' (encode packet)++tests :: [Test]+tests =+	[+		testGroup "Serialization" [+			testCase "000001-006.public_key" (testSerialization "000001-006.public_key"),+			testCase "000002-013.user_id" (testSerialization "000002-013.user_id"),+			testCase "000003-002.sig" (testSerialization "000003-002.sig"),+			testCase "000004-012.ring_trust" (testSerialization "000004-012.ring_trust"),+			testCase "000005-002.sig" (testSerialization "000005-002.sig"),+			testCase "000006-012.ring_trust" (testSerialization "000006-012.ring_trust"),+			testCase "000007-002.sig" (testSerialization "000007-002.sig"),+			testCase "000008-012.ring_trust" (testSerialization "000008-012.ring_trust"),+			testCase "000009-002.sig" (testSerialization "000009-002.sig"),+			testCase "000010-012.ring_trust" (testSerialization "000010-012.ring_trust"),+			testCase "000011-002.sig" (testSerialization "000011-002.sig"),+			testCase "000012-012.ring_trust" (testSerialization "000012-012.ring_trust"),+			testCase "000013-014.public_subkey" (testSerialization "000013-014.public_subkey"),+			testCase "000014-002.sig" (testSerialization "000014-002.sig"),+			testCase "000015-012.ring_trust" (testSerialization "000015-012.ring_trust"),+			testCase "000016-006.public_key" (testSerialization "000016-006.public_key"),+			testCase "000017-002.sig" (testSerialization "000017-002.sig"),+			testCase "000018-012.ring_trust" (testSerialization "000018-012.ring_trust"),+			testCase "000019-013.user_id" (testSerialization "000019-013.user_id"),+			testCase "000020-002.sig" (testSerialization "000020-002.sig"),+			testCase "000021-012.ring_trust" (testSerialization "000021-012.ring_trust"),+			testCase "000022-002.sig" (testSerialization "000022-002.sig"),+			testCase "000023-012.ring_trust" (testSerialization "000023-012.ring_trust"),+			testCase "000024-014.public_subkey" (testSerialization "000024-014.public_subkey"),+			testCase "000025-002.sig" (testSerialization "000025-002.sig"),+			testCase "000026-012.ring_trust" (testSerialization "000026-012.ring_trust"),+			testCase "000027-006.public_key" (testSerialization "000027-006.public_key"),+			testCase "000028-002.sig" (testSerialization "000028-002.sig"),+			testCase "000029-012.ring_trust" (testSerialization "000029-012.ring_trust"),+			testCase "000030-013.user_id" (testSerialization "000030-013.user_id"),+			testCase "000031-002.sig" (testSerialization "000031-002.sig"),+			testCase "000032-012.ring_trust" (testSerialization "000032-012.ring_trust"),+			testCase "000033-002.sig" (testSerialization "000033-002.sig"),+			testCase "000034-012.ring_trust" (testSerialization "000034-012.ring_trust"),+			testCase "000035-006.public_key" (testSerialization "000035-006.public_key"),+			testCase "000036-013.user_id" (testSerialization "000036-013.user_id"),+			testCase "000037-002.sig" (testSerialization "000037-002.sig"),+			testCase "000038-012.ring_trust" (testSerialization "000038-012.ring_trust"),+			testCase "000039-002.sig" (testSerialization "000039-002.sig"),+			testCase "000040-012.ring_trust" (testSerialization "000040-012.ring_trust"),+			testCase "000041-017.attribute" (testSerialization "000041-017.attribute"),+			testCase "000042-002.sig" (testSerialization "000042-002.sig"),+			testCase "000043-012.ring_trust" (testSerialization "000043-012.ring_trust"),+			testCase "000044-014.public_subkey" (testSerialization "000044-014.public_subkey"),+			testCase "000045-002.sig" (testSerialization "000045-002.sig"),+			testCase "000046-012.ring_trust" (testSerialization "000046-012.ring_trust"),+			testCase "000047-005.secret_key" (testSerialization "000047-005.secret_key"),+			testCase "000048-013.user_id" (testSerialization "000048-013.user_id"),+			testCase "000049-002.sig" (testSerialization "000049-002.sig"),+			testCase "000050-012.ring_trust" (testSerialization "000050-012.ring_trust"),+			testCase "000051-007.secret_subkey" (testSerialization "000051-007.secret_subkey"),+			testCase "000052-002.sig" (testSerialization "000052-002.sig"),+			testCase "000053-012.ring_trust" (testSerialization "000053-012.ring_trust"),+			testCase "000054-005.secret_key" (testSerialization "000054-005.secret_key"),+			testCase "000055-002.sig" (testSerialization "000055-002.sig"),+			testCase "000056-012.ring_trust" (testSerialization "000056-012.ring_trust"),+			testCase "000057-013.user_id" (testSerialization "000057-013.user_id"),+			testCase "000058-002.sig" (testSerialization "000058-002.sig"),+			testCase "000059-012.ring_trust" (testSerialization "000059-012.ring_trust"),+			testCase "000060-007.secret_subkey" (testSerialization "000060-007.secret_subkey"),+			testCase "000061-002.sig" (testSerialization "000061-002.sig"),+			testCase "000062-012.ring_trust" (testSerialization "000062-012.ring_trust"),+			testCase "000063-005.secret_key" (testSerialization "000063-005.secret_key"),+			testCase "000064-002.sig" (testSerialization "000064-002.sig"),+			testCase "000065-012.ring_trust" (testSerialization "000065-012.ring_trust"),+			testCase "000066-013.user_id" (testSerialization "000066-013.user_id"),+			testCase "000067-002.sig" (testSerialization "000067-002.sig"),+			testCase "000068-012.ring_trust" (testSerialization "000068-012.ring_trust"),+			testCase "000069-005.secret_key" (testSerialization "000069-005.secret_key"),+			testCase "000070-013.user_id" (testSerialization "000070-013.user_id"),+			testCase "000071-002.sig" (testSerialization "000071-002.sig"),+			testCase "000072-012.ring_trust" (testSerialization "000072-012.ring_trust"),+			testCase "000073-017.attribute" (testSerialization "000073-017.attribute"),+			testCase "000074-002.sig" (testSerialization "000074-002.sig"),+			testCase "000075-012.ring_trust" (testSerialization "000075-012.ring_trust"),+			testCase "000076-007.secret_subkey" (testSerialization "000076-007.secret_subkey"),+			testCase "000077-002.sig" (testSerialization "000077-002.sig"),+			testCase "000078-012.ring_trust" (testSerialization "000078-012.ring_trust"),+			testCase "002182-002.sig" (testSerialization "002182-002.sig"),+			testCase "pubring.gpg" (testSerialization "pubring.gpg"),+			testCase "secring.gpg" (testSerialization "secring.gpg"),+			testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg"),+			testCase "compressedsig-zlib.gpg" (testSerialization "compressedsig-zlib.gpg"),+			testCase "compressedsig-bzip2.gpg" (testSerialization "compressedsig-bzip2.gpg"),+			testCase "onepass_sig" (testSerialization "onepass_sig"),+			testCase "uncompressed-ops-dsa.gpg" (testSerialization "uncompressed-ops-dsa.gpg"),+			testCase "uncompressed-ops-dsa-sha384.txt.gpg" (testSerialization "uncompressed-ops-dsa-sha384.txt.gpg"),+			testCase "uncompressed-ops-rsa.gpg" (testSerialization "uncompressed-ops-rsa.gpg"),+			testProperty "MPI encode/decode" prop_MPI_serialization_loop,+			testProperty "SignatureSubpacket encode/decode" prop_SignatureSubpacket_serialization_loop+		],+		testGroup "S2K count" [+			testProperty "S2K count encode reverses decode" prop_s2k_count+		]+	]++main :: IO ()+main = defaultMain tests