diff --git a/Data/BaseConvert.hs b/Data/BaseConvert.hs deleted file mode 100644 --- a/Data/BaseConvert.hs +++ /dev/null @@ -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) diff --git a/Data/OpenPGP.hs b/Data/OpenPGP.hs --- a/Data/OpenPGP.hs +++ b/Data/OpenPGP.hs @@ -1,587 +1,1131 @@ --- | Main implementation of the OpenPGP message format --- --- 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 +-- +-- 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 diff --git a/Data/OpenPGP/Arbitrary.hs b/Data/OpenPGP/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Data/OpenPGP/Arbitrary.hs @@ -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" diff --git a/Data/OpenPGP/Crypto.hs b/Data/OpenPGP/Crypto.hs deleted file mode 100644 --- a/Data/OpenPGP/Crypto.hs +++ /dev/null @@ -1,173 +0,0 @@ --- | This is a wrapper around --- 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 --- -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 diff --git a/Data/OpenPGP/Internal.hs b/Data/OpenPGP/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/OpenPGP/Internal.hs @@ -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) diff --git a/README b/README --- a/README +++ b/README @@ -7,12 +7,10 @@ and then defines instances of Data.Binary for each to facilitate encoding/decoding. -There is also a wrapper around -that currently does fingerprint generation, signature generation, and -signature verification (for RSA keys only). +For performing cryptography, see + or + -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 diff --git a/openpgp.cabal b/openpgp.cabal --- a/openpgp.cabal +++ b/openpgp.cabal @@ -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 maintainer: Stephen Paul Weber 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 - that currently does fingerprint generation, signature generation, and - signature verification (for RSA keys only). + For performing cryptography, see + or + . - 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 diff --git a/tests/data/000001-006.public_key b/tests/data/000001-006.public_key new file mode 100644 Binary files /dev/null and b/tests/data/000001-006.public_key differ diff --git a/tests/data/000002-013.user_id b/tests/data/000002-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000002-013.user_id @@ -0,0 +1,1 @@ +´$Test Key (RSA) diff --git a/tests/data/000003-002.sig b/tests/data/000003-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000003-002.sig differ diff --git a/tests/data/000004-012.ring_trust b/tests/data/000004-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000004-012.ring_trust differ diff --git a/tests/data/000005-002.sig b/tests/data/000005-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000005-002.sig differ diff --git a/tests/data/000006-012.ring_trust b/tests/data/000006-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000006-012.ring_trust differ diff --git a/tests/data/000007-002.sig b/tests/data/000007-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000007-002.sig differ diff --git a/tests/data/000008-012.ring_trust b/tests/data/000008-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000008-012.ring_trust differ diff --git a/tests/data/000009-002.sig b/tests/data/000009-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000009-002.sig differ diff --git a/tests/data/000010-012.ring_trust b/tests/data/000010-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000010-012.ring_trust differ diff --git a/tests/data/000011-002.sig b/tests/data/000011-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000011-002.sig differ diff --git a/tests/data/000012-012.ring_trust b/tests/data/000012-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000012-012.ring_trust differ diff --git a/tests/data/000013-014.public_subkey b/tests/data/000013-014.public_subkey new file mode 100644 Binary files /dev/null and b/tests/data/000013-014.public_subkey differ diff --git a/tests/data/000014-002.sig b/tests/data/000014-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000014-002.sig differ diff --git a/tests/data/000015-012.ring_trust b/tests/data/000015-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000015-012.ring_trust differ diff --git a/tests/data/000016-006.public_key b/tests/data/000016-006.public_key new file mode 100644 Binary files /dev/null and b/tests/data/000016-006.public_key differ diff --git a/tests/data/000017-002.sig b/tests/data/000017-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000017-002.sig differ diff --git a/tests/data/000018-012.ring_trust b/tests/data/000018-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000018-012.ring_trust differ diff --git a/tests/data/000019-013.user_id b/tests/data/000019-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000019-013.user_id @@ -0,0 +1,1 @@ +´$Test Key (DSA) diff --git a/tests/data/000020-002.sig b/tests/data/000020-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000020-002.sig differ diff --git a/tests/data/000021-012.ring_trust b/tests/data/000021-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000021-012.ring_trust differ diff --git a/tests/data/000022-002.sig b/tests/data/000022-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000022-002.sig differ diff --git a/tests/data/000023-012.ring_trust b/tests/data/000023-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000023-012.ring_trust differ diff --git a/tests/data/000024-014.public_subkey b/tests/data/000024-014.public_subkey new file mode 100644 Binary files /dev/null and b/tests/data/000024-014.public_subkey differ diff --git a/tests/data/000025-002.sig b/tests/data/000025-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000025-002.sig differ diff --git a/tests/data/000026-012.ring_trust b/tests/data/000026-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000026-012.ring_trust differ diff --git a/tests/data/000027-006.public_key b/tests/data/000027-006.public_key new file mode 100644 Binary files /dev/null and b/tests/data/000027-006.public_key differ diff --git a/tests/data/000028-002.sig b/tests/data/000028-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000028-002.sig differ diff --git a/tests/data/000029-012.ring_trust b/tests/data/000029-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000029-012.ring_trust differ diff --git a/tests/data/000030-013.user_id b/tests/data/000030-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000030-013.user_id @@ -0,0 +1,1 @@ +´+Test Key (DSA sign-only) diff --git a/tests/data/000031-002.sig b/tests/data/000031-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000031-002.sig differ diff --git a/tests/data/000032-012.ring_trust b/tests/data/000032-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000032-012.ring_trust differ diff --git a/tests/data/000033-002.sig b/tests/data/000033-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000033-002.sig differ diff --git a/tests/data/000034-012.ring_trust b/tests/data/000034-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000034-012.ring_trust differ diff --git a/tests/data/000035-006.public_key b/tests/data/000035-006.public_key new file mode 100644 Binary files /dev/null and b/tests/data/000035-006.public_key differ diff --git a/tests/data/000036-013.user_id b/tests/data/000036-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000036-013.user_id @@ -0,0 +1,1 @@ +´.Test Key (RSA sign-only) diff --git a/tests/data/000037-002.sig b/tests/data/000037-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000037-002.sig differ diff --git a/tests/data/000038-012.ring_trust b/tests/data/000038-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000038-012.ring_trust differ diff --git a/tests/data/000039-002.sig b/tests/data/000039-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000039-002.sig differ diff --git a/tests/data/000040-012.ring_trust b/tests/data/000040-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000040-012.ring_trust differ diff --git a/tests/data/000041-017.attribute b/tests/data/000041-017.attribute new file mode 100644 Binary files /dev/null and b/tests/data/000041-017.attribute differ diff --git a/tests/data/000042-002.sig b/tests/data/000042-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000042-002.sig differ diff --git a/tests/data/000043-012.ring_trust b/tests/data/000043-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000043-012.ring_trust differ diff --git a/tests/data/000044-014.public_subkey b/tests/data/000044-014.public_subkey new file mode 100644 Binary files /dev/null and b/tests/data/000044-014.public_subkey differ diff --git a/tests/data/000045-002.sig b/tests/data/000045-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000045-002.sig differ diff --git a/tests/data/000046-012.ring_trust b/tests/data/000046-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000046-012.ring_trust differ diff --git a/tests/data/000047-005.secret_key b/tests/data/000047-005.secret_key new file mode 100644 Binary files /dev/null and b/tests/data/000047-005.secret_key differ diff --git a/tests/data/000048-013.user_id b/tests/data/000048-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000048-013.user_id @@ -0,0 +1,1 @@ +´$Test Key (RSA) diff --git a/tests/data/000049-002.sig b/tests/data/000049-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000049-002.sig differ diff --git a/tests/data/000050-012.ring_trust b/tests/data/000050-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000050-012.ring_trust differ diff --git a/tests/data/000051-007.secret_subkey b/tests/data/000051-007.secret_subkey new file mode 100644 Binary files /dev/null and b/tests/data/000051-007.secret_subkey differ diff --git a/tests/data/000052-002.sig b/tests/data/000052-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000052-002.sig differ diff --git a/tests/data/000053-012.ring_trust b/tests/data/000053-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000053-012.ring_trust differ diff --git a/tests/data/000054-005.secret_key b/tests/data/000054-005.secret_key new file mode 100644 Binary files /dev/null and b/tests/data/000054-005.secret_key differ diff --git a/tests/data/000055-002.sig b/tests/data/000055-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000055-002.sig differ diff --git a/tests/data/000056-012.ring_trust b/tests/data/000056-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000056-012.ring_trust differ diff --git a/tests/data/000057-013.user_id b/tests/data/000057-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000057-013.user_id @@ -0,0 +1,1 @@ +´$Test Key (DSA) diff --git a/tests/data/000058-002.sig b/tests/data/000058-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000058-002.sig differ diff --git a/tests/data/000059-012.ring_trust b/tests/data/000059-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000059-012.ring_trust differ diff --git a/tests/data/000060-007.secret_subkey b/tests/data/000060-007.secret_subkey new file mode 100644 Binary files /dev/null and b/tests/data/000060-007.secret_subkey differ diff --git a/tests/data/000061-002.sig b/tests/data/000061-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000061-002.sig differ diff --git a/tests/data/000062-012.ring_trust b/tests/data/000062-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000062-012.ring_trust differ diff --git a/tests/data/000063-005.secret_key b/tests/data/000063-005.secret_key new file mode 100644 Binary files /dev/null and b/tests/data/000063-005.secret_key differ diff --git a/tests/data/000064-002.sig b/tests/data/000064-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000064-002.sig differ diff --git a/tests/data/000065-012.ring_trust b/tests/data/000065-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000065-012.ring_trust differ diff --git a/tests/data/000066-013.user_id b/tests/data/000066-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000066-013.user_id @@ -0,0 +1,1 @@ +´+Test Key (DSA sign-only) diff --git a/tests/data/000067-002.sig b/tests/data/000067-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000067-002.sig differ diff --git a/tests/data/000068-012.ring_trust b/tests/data/000068-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000068-012.ring_trust differ diff --git a/tests/data/000069-005.secret_key b/tests/data/000069-005.secret_key new file mode 100644 Binary files /dev/null and b/tests/data/000069-005.secret_key differ diff --git a/tests/data/000070-013.user_id b/tests/data/000070-013.user_id new file mode 100644 --- /dev/null +++ b/tests/data/000070-013.user_id @@ -0,0 +1,1 @@ +´.Test Key (RSA sign-only) diff --git a/tests/data/000071-002.sig b/tests/data/000071-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000071-002.sig differ diff --git a/tests/data/000072-012.ring_trust b/tests/data/000072-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000072-012.ring_trust differ diff --git a/tests/data/000073-017.attribute b/tests/data/000073-017.attribute new file mode 100644 Binary files /dev/null and b/tests/data/000073-017.attribute differ diff --git a/tests/data/000074-002.sig b/tests/data/000074-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000074-002.sig differ diff --git a/tests/data/000075-012.ring_trust b/tests/data/000075-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000075-012.ring_trust differ diff --git a/tests/data/000076-007.secret_subkey b/tests/data/000076-007.secret_subkey new file mode 100644 Binary files /dev/null and b/tests/data/000076-007.secret_subkey differ diff --git a/tests/data/000077-002.sig b/tests/data/000077-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/000077-002.sig differ diff --git a/tests/data/000078-012.ring_trust b/tests/data/000078-012.ring_trust new file mode 100644 Binary files /dev/null and b/tests/data/000078-012.ring_trust differ diff --git a/tests/data/compressedsig-bzip2.gpg b/tests/data/compressedsig-bzip2.gpg new file mode 100644 Binary files /dev/null and b/tests/data/compressedsig-bzip2.gpg differ diff --git a/tests/data/compressedsig-zlib.gpg b/tests/data/compressedsig-zlib.gpg new file mode 100644 Binary files /dev/null and b/tests/data/compressedsig-zlib.gpg differ diff --git a/tests/data/compressedsig.gpg b/tests/data/compressedsig.gpg new file mode 100644 Binary files /dev/null and b/tests/data/compressedsig.gpg differ diff --git a/tests/data/onepass_sig b/tests/data/onepass_sig new file mode 100644 Binary files /dev/null and b/tests/data/onepass_sig differ diff --git a/tests/data/pubring.gpg b/tests/data/pubring.gpg new file mode 100644 Binary files /dev/null and b/tests/data/pubring.gpg differ diff --git a/tests/data/secring.gpg b/tests/data/secring.gpg new file mode 100644 Binary files /dev/null and b/tests/data/secring.gpg differ diff --git a/tests/data/uncompressed-ops-dsa-sha384.txt.gpg b/tests/data/uncompressed-ops-dsa-sha384.txt.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uncompressed-ops-dsa-sha384.txt.gpg differ diff --git a/tests/data/uncompressed-ops-dsa.gpg b/tests/data/uncompressed-ops-dsa.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uncompressed-ops-dsa.gpg differ diff --git a/tests/data/uncompressed-ops-rsa.gpg b/tests/data/uncompressed-ops-rsa.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uncompressed-ops-rsa.gpg differ diff --git a/tests/suite.hs b/tests/suite.hs new file mode 100644 --- /dev/null +++ b/tests/suite.hs @@ -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