openpgp (empty) → 0.1
raw patch · 7 files changed
+781/−0 lines, 7 filesdep +Cryptodep +basedep +binarysetup-changed
Dependencies added: Crypto, base, binary, bytestring, bzlib, containers, utf8-string, zlib
Files
- COPYING +13/−0
- Data/BaseConvert.hs +30/−0
- Data/OpenPGP.hs +578/−0
- Data/OpenPGP/Crypto.hs +93/−0
- README +12/−0
- Setup.hs +3/−0
- openpgp.cabal +52/−0
+ COPYING view
@@ -0,0 +1,13 @@+Copyright © 2011, Stephen Paul Weber <singpolyma.net>++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.
+ Data/BaseConvert.hs view
@@ -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)
+ Data/OpenPGP.hs view
@@ -0,0 +1,578 @@+-- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880>+--+-- The recommended way to import this module is:+--+-- > import qualified Data.OpenPGP as OpenPGP+module Data.OpenPGP (Message(..), Packet(..), SignatureSubpacket(..), HashAlgorithm(..), KeyAlgorithm(..), CompressionAlgorithm(..), MPI(..), fingerprint_material, signatures_and_data, signature_issuer) 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 ++ "."
+ Data/OpenPGP/Crypto.hs view
@@ -0,0 +1,93 @@+-- | This is a wrapper around <http://hackage.haskell.org/package/Crypto>+-- that currently does fingerprint generation and signature verification.+--+-- The recommended way to import this module is:+--+-- > import qualified Data.OpenPGP.Crypto as OpenPGP+module Data.OpenPGP.Crypto (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+-- <http://tools.ietf.org/html/rfc4880#section-12.2>+fingerprint :: OpenPGP.Packet -> String+fingerprint p | OpenPGP.version p == 4 =+ BaseConvert.toString 16 $ SHA1.toInteger $ SHA1.hash $+ LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p))+fingerprint p | OpenPGP.version p `elem` [2, 3] =+ concatMap (BaseConvert.toString 16) $+ MD5.hash $ LZ.unpack (LZ.concat (OpenPGP.fingerprint_material p))+fingerprint _ = error "Unsupported Packet version or type in fingerprint."++find_key :: OpenPGP.Message -> String -> Maybe OpenPGP.Packet+find_key (OpenPGP.Message (x@(OpenPGP.PublicKeyPacket {}):xs)) keyid =+ find_key_ x xs keyid+find_key (OpenPGP.Message (x@(OpenPGP.SecretKeyPacket {}):xs)) keyid =+ find_key_ x xs keyid+find_key _ _ = Nothing++find_key_ :: OpenPGP.Packet -> [OpenPGP.Packet] -> String -> Maybe OpenPGP.Packet+find_key_ x xs keyid =+ if thisid == keyid then Just x else find_key (OpenPGP.Message xs) keyid+ where thisid = reverse $+ take (length keyid) (reverse (fingerprint x))++keyfield_as_octets :: OpenPGP.Packet -> Char -> [Word8]+keyfield_as_octets k f =+ LZ.unpack $ LZ.drop 2 (encode (k' ! f))+ where k' = OpenPGP.key k++-- http://tools.ietf.org/html/rfc3447#page-43+emsa_pkcs1_v1_5_hash_padding :: OpenPGP.HashAlgorithm -> [Word8]+emsa_pkcs1_v1_5_hash_padding OpenPGP.MD5 = [0x30, 0x20, 0x30, 0x0c, 0x06, 0x08, 0x2a, 0x86, 0x48, 0x86, 0xf7, 0x0d, 0x02, 0x05, 0x05, 0x00, 0x04, 0x10]+emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA1 = [0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14]+emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA256 = [0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20]+emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA384 = [0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30]+emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA512 = [0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40]+emsa_pkcs1_v1_5_hash_padding _ =+ error "Unsupported HashAlgorithm in emsa_pkcs1_v1_5_hash_padding."++hash :: OpenPGP.HashAlgorithm -> [Word8] -> [Word8]+hash OpenPGP.MD5 = MD5.hash+hash OpenPGP.SHA1 = reverse . drop 2 . LZ.unpack . encode . OpenPGP.MPI . SHA1.toInteger . SHA1.hash+hash OpenPGP.SHA256 = SHA256.hash+hash OpenPGP.SHA384 = SHA384.hash+hash OpenPGP.SHA512 = SHA512.hash+hash _ = error "Unsupported HashAlgorithm in hash."++emsa_pkcs1_v1_5_encode :: [Word8] -> Int -> OpenPGP.HashAlgorithm -> [Word8]+emsa_pkcs1_v1_5_encode m emLen algo =+ [0, 1] ++ replicate (emLen - length t - 3) 0xff ++ [0] ++ t+ where t = emsa_pkcs1_v1_5_hash_padding algo ++ hash algo m++-- | Verify a message signature. Only supports RSA keys for now.+verify :: OpenPGP.Message -- ^ Keys that may have made the signature+ -> OpenPGP.Message -- ^ 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
+ README view
@@ -0,0 +1,12 @@+OpenPGP-Haskell++This is an OpenPGP library inspired by my work on OpenPGP-PHP <http://github.com/bendiken/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 <http://hackage.haskell.org/package/Crypto> 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
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ openpgp.cabal view
@@ -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 <singpolyma@singpolyma.net>+maintainer: Stephen Paul Weber <singpolyma@singpolyma.net>+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 <http://github.com/bendiken/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 <http://hackage.haskell.org/package/Crypto>+ 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