From aa8529550515d2a1a59adff2fc5dbd4235b92f18 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Mon, 8 Aug 2011 21:47:10 -0500 Subject: Move into Data hierarchy --- Data/BaseConvert.hs | 30 +++ Data/OpenPGP.hs | 573 +++++++++++++++++++++++++++++++++++++++++++++++++ Data/OpenPGP/Crypto.hs | 82 +++++++ lib/BaseConvert.hs | 30 --- lib/OpenPGP.Crypto.hs | 82 ------- lib/OpenPGP.hs | 573 ------------------------------------------------- 6 files changed, 685 insertions(+), 685 deletions(-) create mode 100644 Data/BaseConvert.hs create mode 100644 Data/OpenPGP.hs create mode 100644 Data/OpenPGP/Crypto.hs delete mode 100644 lib/BaseConvert.hs delete mode 100644 lib/OpenPGP.Crypto.hs delete mode 100644 lib/OpenPGP.hs diff --git a/Data/BaseConvert.hs b/Data/BaseConvert.hs new file mode 100644 index 0000000..655f593 --- /dev/null +++ b/Data/BaseConvert.hs @@ -0,0 +1,30 @@ +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 new file mode 100644 index 0000000..1c76202 --- /dev/null +++ b/Data/OpenPGP.hs @@ -0,0 +1,573 @@ +module Data.OpenPGP (Message(..), Packet(..), SignatureSubpacket(..), HashAlgorithm(..), KeyAlgorithm(..), CompressionAlgorithm(..), MPI(..), fingerprint_material, signatures_and_data, signature_issuer) 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 (fmap 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) +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 do + return (Message []) + else do + next_packet <- get :: Get Packet + (Message tail) <- get :: Get Message + return (Message (next_packet:tail)) + +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.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.foldr (\b a -> + 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 + return $ runGet (parse_signature_subpacket tag) packet + +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 do + 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) ++ "." diff --git a/Data/OpenPGP/Crypto.hs b/Data/OpenPGP/Crypto.hs new file mode 100644 index 0000000..e2151fc --- /dev/null +++ b/Data/OpenPGP/Crypto.hs @@ -0,0 +1,82 @@ +module Data.OpenPGP.Crypto (verify, fingerprint) where + +import Data.Word +import Data.Map ((!)) +import qualified Data.ByteString.Lazy as LZ + +import Data.Binary +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 + +-- http://tools.ietf.org/html/rfc4880#section-12.2 +fingerprint :: OpenPGP.Packet -> String +fingerprint p | OpenPGP.version p == 4 = + BaseConvert.toString 16 $ SHA1.toInteger $ SHA1.hash $ + LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p)) +fingerprint p | OpenPGP.version p `elem` [2, 3] = + concatMap (BaseConvert.toString 16) $ + MD5.hash $ LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p)) +fingerprint _ = error "Unsupported Packet version or type in fingerprint." + +find_key :: OpenPGP.Message -> String -> Maybe OpenPGP.Packet +find_key (OpenPGP.Message (x@(OpenPGP.PublicKeyPacket {}):xs)) keyid = + find_key_ x xs keyid +find_key (OpenPGP.Message (x@(OpenPGP.SecretKeyPacket {}):xs)) keyid = + find_key_ x xs keyid +find_key _ _ = Nothing + +find_key_ :: OpenPGP.Packet -> [OpenPGP.Packet] -> String -> Maybe OpenPGP.Packet +find_key_ x xs keyid = + if thisid == keyid then Just x else find_key (OpenPGP.Message xs) keyid + where thisid = reverse $ + take (length keyid) (reverse (fingerprint x)) + +keyfield_as_octets :: OpenPGP.Packet -> Char -> [Word8] +keyfield_as_octets k f = + LZ.unpack $ LZ.drop 2 (encode (k' ! f)) + where k' = OpenPGP.key k + +-- http://tools.ietf.org/html/rfc3447#page-43 +emsa_pkcs1_v1_5_hash_padding :: OpenPGP.HashAlgorithm -> [Word8] +emsa_pkcs1_v1_5_hash_padding OpenPGP.MD5 = [0x30, 0x20, 0x30, 0x0c, 0x06, 0x08, 0x2a, 0x86, 0x48, 0x86, 0xf7, 0x0d, 0x02, 0x05, 0x05, 0x00, 0x04, 0x10] +emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA1 = [0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14] +emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA256 = [0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20] +emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA384 = [0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30] +emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA512 = [0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40] +emsa_pkcs1_v1_5_hash_padding _ = + error "Unsupported HashAlgorithm in emsa_pkcs1_v1_5_hash_padding." + +hash :: OpenPGP.HashAlgorithm -> [Word8] -> [Word8] +hash OpenPGP.MD5 = MD5.hash +hash OpenPGP.SHA1 = reverse . drop 2 . LZ.unpack . encode . OpenPGP.MPI . SHA1.toInteger . SHA1.hash +hash OpenPGP.SHA256 = SHA256.hash +hash OpenPGP.SHA384 = SHA384.hash +hash OpenPGP.SHA512 = SHA512.hash +hash _ = error "Unsupported HashAlgorithm in hash." + +emsa_pkcs1_v1_5_encode :: [Word8] -> Int -> OpenPGP.HashAlgorithm -> [Word8] +emsa_pkcs1_v1_5_encode m emLen algo = + [0, 1] ++ replicate (emLen - length t - 3) 0xff ++ [0] ++ t + where t = emsa_pkcs1_v1_5_hash_padding algo ++ hash algo m + +verify :: OpenPGP.Message -> OpenPGP.Message -> Int -> Bool +verify keys packet 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 packet diff --git a/lib/BaseConvert.hs b/lib/BaseConvert.hs deleted file mode 100644 index 1f5c040..0000000 --- a/lib/BaseConvert.hs +++ /dev/null @@ -1,30 +0,0 @@ -module 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/lib/OpenPGP.Crypto.hs b/lib/OpenPGP.Crypto.hs deleted file mode 100644 index 240919d..0000000 --- a/lib/OpenPGP.Crypto.hs +++ /dev/null @@ -1,82 +0,0 @@ -module OpenPGP.Crypto (verify, fingerprint) where - -import Data.Word -import Data.Map ((!)) -import qualified Data.ByteString.Lazy as LZ - -import Data.Binary -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 OpenPGP as OpenPGP -import qualified BaseConvert as BaseConvert - --- http://tools.ietf.org/html/rfc4880#section-12.2 -fingerprint :: OpenPGP.Packet -> String -fingerprint p | OpenPGP.version p == 4 = - BaseConvert.toString 16 $ SHA1.toInteger $ SHA1.hash $ - LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p)) -fingerprint p | OpenPGP.version p `elem` [2, 3] = - concatMap (BaseConvert.toString 16) $ - MD5.hash $ LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p)) -fingerprint _ = error "Unsupported Packet version or type in fingerprint." - -find_key :: OpenPGP.Message -> String -> Maybe OpenPGP.Packet -find_key (OpenPGP.Message (x@(OpenPGP.PublicKeyPacket {}):xs)) keyid = - find_key_ x xs keyid -find_key (OpenPGP.Message (x@(OpenPGP.SecretKeyPacket {}):xs)) keyid = - find_key_ x xs keyid -find_key _ _ = Nothing - -find_key_ :: OpenPGP.Packet -> [OpenPGP.Packet] -> String -> Maybe OpenPGP.Packet -find_key_ x xs keyid = - if thisid == keyid then Just x else find_key (OpenPGP.Message xs) keyid - where thisid = reverse $ - take (length keyid) (reverse (fingerprint x)) - -keyfield_as_octets :: OpenPGP.Packet -> Char -> [Word8] -keyfield_as_octets k f = - LZ.unpack $ LZ.drop 2 (encode (k' ! f)) - where k' = OpenPGP.key k - --- http://tools.ietf.org/html/rfc3447#page-43 -emsa_pkcs1_v1_5_hash_padding :: OpenPGP.HashAlgorithm -> [Word8] -emsa_pkcs1_v1_5_hash_padding OpenPGP.MD5 = [0x30, 0x20, 0x30, 0x0c, 0x06, 0x08, 0x2a, 0x86, 0x48, 0x86, 0xf7, 0x0d, 0x02, 0x05, 0x05, 0x00, 0x04, 0x10] -emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA1 = [0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14] -emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA256 = [0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20] -emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA384 = [0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30] -emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA512 = [0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40] -emsa_pkcs1_v1_5_hash_padding _ = - error "Unsupported HashAlgorithm in emsa_pkcs1_v1_5_hash_padding." - -hash :: OpenPGP.HashAlgorithm -> [Word8] -> [Word8] -hash OpenPGP.MD5 = MD5.hash -hash OpenPGP.SHA1 = reverse . drop 2 . LZ.unpack . encode . OpenPGP.MPI . SHA1.toInteger . SHA1.hash -hash OpenPGP.SHA256 = SHA256.hash -hash OpenPGP.SHA384 = SHA384.hash -hash OpenPGP.SHA512 = SHA512.hash -hash _ = error "Unsupported HashAlgorithm in hash." - -emsa_pkcs1_v1_5_encode :: [Word8] -> Int -> OpenPGP.HashAlgorithm -> [Word8] -emsa_pkcs1_v1_5_encode m emLen algo = - [0, 1] ++ replicate (emLen - length t - 3) 0xff ++ [0] ++ t - where t = emsa_pkcs1_v1_5_hash_padding algo ++ hash algo m - -verify :: OpenPGP.Message -> OpenPGP.Message -> Int -> Bool -verify keys packet 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 packet diff --git a/lib/OpenPGP.hs b/lib/OpenPGP.hs deleted file mode 100644 index 55fd3fc..0000000 --- a/lib/OpenPGP.hs +++ /dev/null @@ -1,573 +0,0 @@ -module OpenPGP (Message(..), Packet(..), SignatureSubpacket(..), HashAlgorithm(..), KeyAlgorithm(..), CompressionAlgorithm(..), MPI(..), fingerprint_material, signatures_and_data, signature_issuer) 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 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 (fmap 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) -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 do - return (Message []) - else do - next_packet <- get :: Get Packet - (Message tail) <- get :: Get Message - return (Message (next_packet:tail)) - -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.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.foldr (\b a -> - 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 - return $ runGet (parse_signature_subpacket tag) packet - -signature_issuer :: OpenPGP.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 do - 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) ++ "." -- cgit v1.2.3