diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,13 @@ +Copyright © 2011, Stephen Paul Weber + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/Data/BaseConvert.hs b/Data/BaseConvert.hs new file mode 100644 --- /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 --- /dev/null +++ b/Data/OpenPGP.hs @@ -0,0 +1,578 @@ +-- | 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) 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) +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.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 + +-- | 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 ++ "." diff --git a/Data/OpenPGP/Crypto.hs b/Data/OpenPGP/Crypto.hs new file mode 100644 --- /dev/null +++ b/Data/OpenPGP/Crypto.hs @@ -0,0 +1,93 @@ +-- | 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 (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 + +-- | 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 -- ^ Message containing data and signature packet + -> 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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,12 @@ +OpenPGP-Haskell + +This is an OpenPGP library inspired by my work on OpenPGP-PHP . + +It defines types Message and Packet to represent OpenPGP messages as series of packets and then defines instances of Data.Binary for each to facilitate encoding/decoding. + +There is also a wrapper around that currently does fingerprint generation and signature verification. + +It is intended that you use qualified imports with this library. If importing both modules, something like this will do: + +> import qualified Data.OpenPGP as OpenPGP +> import qualified Data.OpenPGP.Crypto as OpenPGP diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/openpgp.cabal b/openpgp.cabal new file mode 100644 --- /dev/null +++ b/openpgp.cabal @@ -0,0 +1,52 @@ +name: openpgp +version: 0.1 +cabal-version: >= 1.8 +license: OtherLicense +license-file: COPYING +category: Data +copyright: © 2011 Stephen Paul Weber +author: Stephen Paul Weber +maintainer: Stephen Paul Weber +stability: experimental +tested-with: GHC == 7.0.3 +synopsis: Implementation of the OpenPGP message format +homepage: http://github.com/singpolyma/OpenPGP-Haskell +bug-reports: http://github.com/singpolyma/OpenPGP-Haskell/issues +build-type: Simple +description: This is an OpenPGP library inspired by my work on OpenPGP-PHP . + It defines types Message and Packet to represent OpenPGP messages as series + of packets and then defines instances of Data.Binary for each to facilitate + encoding/decoding. + . + There is also a wrapper around + that currently does fingerprint generation and signature verification. + . + It is intended that you use qualified imports with this library. If importing both modules, something like this will do: + . + > import qualified Data.OpenPGP as OpenPGP + > import qualified Data.OpenPGP.Crypto as OpenPGP + +extra-source-files: + README + +library + exposed-modules: + Data.OpenPGP + Data.OpenPGP.Crypto + + other-modules: + Data.BaseConvert + + build-depends: + base == 4.*, + containers, + bytestring, + utf8-string, + binary, + zlib, + bzlib, + Crypto + +source-repository head + type: git + location: git://github.com/singpolyma/OpenPGP-Haskell.git