hOpenPGP 0.1 → 0.2

raw patch · 17 files changed

+865/−197 lines, 17 filesdep +asn1-datadep +bzlibdep +cereal-conduitbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: asn1-data, bzlib, cereal-conduit, conduit, cryptocipher, cryptohash, mtl, split, zlib

API changes (from Hackage documentation)

Files

• Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs +4/−3
• Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs +3/−2
• Codec/Encryption/OpenPGP/Compression.hs +43/−0
• Codec/Encryption/OpenPGP/Fingerprint.hs +18/−0
• Codec/Encryption/OpenPGP/Internal.hs +29/−0
• Codec/Encryption/OpenPGP/Serialize.hs +182/−121
• Codec/Encryption/OpenPGP/SerializeForSigs.hs +95/−0
• Codec/Encryption/OpenPGP/Types.hs +61/−8
• Data/Conduit/Cereal/Temp.hs +31/−0
• Data/Conduit/OpenPGP/Compression.hs +23/−0
• Data/Conduit/OpenPGP/Keyring.hs +83/−0
• Data/Conduit/OpenPGP/Verify.hs +158/−0
• hOpenPGP.cabal +32/−3
• tests/data/compressedsig.gpg binary
• tests/data/uncompressed-ops-dsa.gpg binary
• tests/data/uncompressed-ops-rsa.gpg binary
• tests/suite.hs +103/−60

@@ -9,7 +9,7 @@  , decodeArmor ) where -import Codec.Encryption.OpenPGP.Serialize (getPackets)+import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Control.Applicative (many, (<|>), (<$>)) import Data.Attoparsec.ByteString (Parser, many1, string, inClass, notInClass, satisfy, word8, (<?>), parse, IResult(..))@@ -20,6 +20,7 @@ import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Base64 as Base64 import Data.Digest.CRC24 (crc24)+import Data.Serialize (get) import Data.Serialize.Get (Get, runGet, getWord8) import Data.Serialize.Put (runPut, putWord32be) import Data.String (IsString, fromString)@@ -38,9 +39,9 @@     blankishLine <?> "blank line"     payload <- base64Data <?> "base64 data"     endLine atype <?> "end line"-    case runGet getPackets payload of+    case runGet get payload of         Left err -> fail err-        Right packets -> return $ Armor atype headers packets+        Right packets -> return $ Armor atype headers (unBlock packets)  beginLine :: (Integral a, Read a, Show a) => Parser (ArmorType a) beginLine = do

@@ -7,13 +7,14 @@    armor ) where -import Codec.Encryption.OpenPGP.Serialize (putPackets)+import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Base64 as Base64 import Data.Digest.CRC24 (crc24)+import Data.Serialize (put) import Data.Serialize.Put (runPut, putWord32be) import Data.String (IsString, fromString) @@ -44,7 +45,7 @@         armorHeader (k, v) = k `B.append` BC8.pack ": " `B.append` v  opgpStream :: [Packet] -> ByteString-opgpStream = runPut . putPackets+opgpStream = runPut . put . Block  armorData :: ByteString -> ByteString armorData = BC8.unlines . wrap76 . Base64.encode

@@ -0,0 +1,43 @@+-- ASCIIArmor.hs: OpenPGP (RFC4880) ASCII armor implementation+-- Copyright Ⓒ 2012  Clint Adams+-- This software is released under the terms of the Expat (MIT) license.+-- (See the LICENSE file).++module Codec.Encryption.OpenPGP.Compression (+   decompressPacket+ , compressPackets+) where++import qualified Codec.Compression.BZip as BZip+import qualified Codec.Compression.Zlib as Zlib+import qualified Codec.Compression.Zlib.Raw as ZlibRaw+import Codec.Encryption.OpenPGP.Serialize+import Codec.Encryption.OpenPGP.Types+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Serialize (get, put)+import Data.Serialize.Get (runGet)+import Data.Serialize.Put (runPut)++decompressPacket :: Packet -> [Packet]+decompressPacket (CompressedData algo bs) = case (runGet get . B.concat . BL.toChunks) (decompressPacket' algo bs) of+                       Left _ -> []+                       Right packs -> unBlock packs+    where+        decompressPacket' :: CompressionAlgorithm -> ByteString -> BL.ByteString+        decompressPacket' ZIP bs = ZlibRaw.decompress $ BL.fromChunks [bs]+        decompressPacket' ZLIB bs = Zlib.decompress $ BL.fromChunks [bs]+        decompressPacket' BZip2 bs = BZip.decompress $ BL.fromChunks [bs]+decompressPacket p = [p]++compressPackets :: CompressionAlgorithm -> [Packet] -> Packet+compressPackets ca packs = do+    let bs = runPut $ put (Block packs)+    let cbs = B.concat . BL.toChunks $ compressPackets' ca bs+    CompressedData ca cbs+    where+        compressPackets' :: CompressionAlgorithm -> ByteString -> BL.ByteString+        compressPackets' ZIP bs = ZlibRaw.compress $ BL.fromChunks [bs]+        compressPackets' ZLIB bs = Zlib.compress $ BL.fromChunks [bs]+        compressPackets' BZip2 bs = BZip.compress $ BL.fromChunks [bs]

@@ -0,0 +1,18 @@+module Codec.Encryption.OpenPGP.Fingerprint (+   eightOctetKeyID+ , fingerprint+) where++import qualified Crypto.Hash.SHA1 as SHA1+import qualified Data.ByteString as B+import Data.Word (Word64)+import Data.Serialize.Put (runPut)++import Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting)+import Codec.Encryption.OpenPGP.Types++eightOctetKeyID :: PKPayload -> EightOctetKeyId+eightOctetKeyID = EightOctetKeyId . B.drop 12 . unTOF . fingerprint++fingerprint :: PKPayload -> TwentyOctetFingerprint+fingerprint (PubV4 ts pka pk) = (TwentyOctetFingerprint . SHA1.hash) (runPut $ putPKPforFingerprinting (PublicKey (PubV4 ts pka pk)))

@@ -0,0 +1,29 @@+-- Internal.hs: private utility functions+-- Copyright Ⓒ 2012  Clint Adams+-- This software is released under the terms of the Expat (MIT) license.+-- (See the LICENSE file).++module Codec.Encryption.OpenPGP.Internal (+   countBits+ , beBSToInteger+ , integerToBEBS+) where++import Data.Bits (testBit, shiftL, shiftR, (.&.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.List (mapAccumR, unfoldr)+import Data.Word (Word8, Word16)++countBits :: ByteString -> Word16+countBits bs = fromIntegral (B.length bs * 8) - fromIntegral (go (B.head bs) 7)+    where+        go :: Word8 -> Int -> Word8+        go n 0 = 7+        go n b = if testBit n b then 7 - fromIntegral b else go n (b-1)++beBSToInteger :: ByteString -> Integer+beBSToInteger = foldr1 (+) . snd . (mapAccumR (\acc x -> (acc + 8, fromIntegral x `shiftL` acc)) 0) . B.unpack++integerToBEBS :: Integer -> ByteString+integerToBEBS = B.pack . reverse . unfoldr (\x -> if x == 0 then Nothing else Just ((fromIntegral x :: Word8) .&. 0xff, x `shiftR` 8))

@@ -4,12 +4,12 @@ -- (See the LICENSE file).  module Codec.Encryption.OpenPGP.Serialize (-    getPackets-  , putPackets ) where  import Control.Applicative ((<$>),(<*>)) import Control.Monad (replicateM, mplus, when)+import qualified Crypto.Cipher.RSA as R+import qualified Crypto.Cipher.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.ByteString (ByteString) import qualified Data.ByteString as B@@ -21,8 +21,9 @@ import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putWord16le, runPut) import Data.Set (Set) import qualified Data.Set as Set-import Data.Word (Word8)+import Data.Word (Word8, Word16) +import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS) import Codec.Encryption.OpenPGP.Types  instance Serialize SigSubPacket where@@ -64,6 +65,22 @@     get = getS2K     put = putS2K +instance Serialize Packet where+    get = getPacket+    put = putPacket++instance Serialize a => Serialize (Block a) where+    get = Block `fmap` many get+    put = mapM_ put . unBlock++instance Serialize PKPayload where+    get = getPKPayload+    put = putPKPayload++instance Serialize SignaturePayload where+    get = getSignaturePayload+    put = putSignaturePayload+ getSigSubPacket :: Get SigSubPacket getSigSubPacket = do     l <- getSubPacketLength@@ -101,10 +118,10 @@                        rclass <- getWord8                        algid <- get                        fp <- getByteString 20-                       return $ RevocationKey crit (bsToFFSet . B.singleton $ rclass) algid fp+                       return $ RevocationKey crit (bsToFFSet . B.singleton $ rclass) algid (TwentyOctetFingerprint fp)             | pt == 16 = do                        keyid <- getByteString (l - 1)-                       return $ Issuer crit keyid+                       return $ Issuer crit (EightOctetKeyId keyid)             | pt == 20 = do                        flags <- getByteString 4                        nl <- getWord16be@@ -198,11 +215,11 @@     putSigSubPacketType crit 12     putByteString . ffSetToFixedLengthBS 1 $ rclass     put algid-    putByteString fp -- 20 octets+    putByteString (unTOF fp) -- 20 octets putSigSubPacket (Issuer crit keyid) = do     putSubPacketLength 9     putSigSubPacketType crit 16-    putByteString keyid -- 8 octets+    putByteString (unEOKI keyid) -- 8 octets putSigSubPacket (NotationData crit nfs nn nv) = do     putSubPacketLength (9 + B.length nn + B.length nv)     putSigSubPacketType crit 20@@ -374,28 +391,36 @@     putByteString salt     putWord8 $ encodeIterationCount count -getPacketTypeAndLength :: Get (Word8, Int)-getPacketTypeAndLength = do+getPacketTypeAndPayload :: Get (Word8, ByteString)+getPacketTypeAndPayload = do     tag <- getWord8 -- FIXME: bit 7 must be 1, check?     case tag .&. 0x40 of         0x00 -> do                    let t = shiftR (tag .&. 0x3c) 2                    case tag .&. 0x03 of                        0 -> do len <- getWord8-                               return (t, fromIntegral len)+                               bs <- getByteString (fromIntegral len)+                               return (t, bs)                        1 -> do len <- getWord16be-                               return (t, fromIntegral len)+                               bs <- getByteString (fromIntegral len)+                               return (t, bs)                        2 -> do len <- getWord32be-                               return (t, fromIntegral len)-                       3 -> return (t, maxBound)  -- FIXME: express this better+                               bs <- getByteString (fromIntegral len)+                               return (t, bs)+                       3 -> do len <- remaining+                               bs <- getByteString len+                               return (t, bs)         0x40 -> do                    len <- getPacketLength-                   return (tag .&. 0x3f, len)+                   bs <- getByteString len+                   return (tag .&. 0x3f, bs)  getPacket :: Get Packet getPacket = do-               (t, len) <- getPacketTypeAndLength-               getPacket' t len+    (t, pl) <- getPacketTypeAndPayload+    case runGet (getPacket' t (B.length pl)) pl of+        Left e -> fail e+        Right p -> return p     where         getPacket' :: Word8 -> Int -> Get Packet         getPacket' t len@@ -404,44 +429,13 @@                           eokeyid <- getByteString 8                           pkalgo <- getWord8                           sk <- getByteString (len - 10)-                          return $ PKESK pv eokeyid (toFVal pkalgo) sk+                          return $ PKESK pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk             | t == 2 = do-                          pv <- getWord8-                          case pv of-                              3 -> do-                                      hashlen <- getWord8 -- must be 5-                                      st <- getWord8-                                      ctime <- getWord32be-                                      eok <- getByteString 8-                                      pka <- get-                                      ha <- get-                                      left16 <- getWord16be-                                      mpib <- getBytes (len - 19)-                                      case runGet (many getMPI) mpib of-                                          Left e -> error e-                                          Right mpis -> return $ Signature $ SigV3 (toFVal st) ctime eok (toFVal pka) (toFVal ha) left16 mpis-                              4 -> do-                                      st <- getWord8-                                      pka <- get-                                      ha <- get-                                      hlen <- getWord16be-                                      hb <- getBytes (fromIntegral hlen)-                                      let hashed = case runGet (many getSigSubPacket) hb of-                                                        Left err -> error err-                                                        Right h -> h-                                      ulen <- getWord16be-                                      ub <- getBytes (fromIntegral ulen)-                                      let unhashed = case runGet (many getSigSubPacket) ub of-                                                        Left err -> error err-                                                        Right u -> u-                                      left16 <- getWord16be-                                      mpib <- getBytes (len - (10 + (fromIntegral hlen) + (fromIntegral ulen)))-                                      case runGet (many getMPI) mpib of-                                          Left e -> error e-                                          Right mpis -> return $ Signature $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 mpis-                              otherwise -> do-                                               bs <- getByteString (len - 1)-                                               return $ Signature $ SigVOther pv bs+                          remainder <- remaining+                          bs <- getBytes remainder+                          case runGet get bs of+                              Left e -> error e+                              Right sp -> return $ Signature sp             | t == 3 = do                           pv <- getWord8                           symalgo <- getWord8@@ -459,7 +453,7 @@                           pka <- getWord8                           skeyid <- getByteString 8                           nested <- getWord8-                          return $ OnePassSignature pv (toFVal sigtype) (toFVal ha) (toFVal pka) skeyid (nested == 0)+                          return $ OnePassSignature pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0)             | t == 5 = do                           bs <- getBytes len                           let ps = flip runGet bs $ do pkp <- getPKPayload@@ -571,37 +565,12 @@     let bsk = sk     putPacketLength $ 10 + (B.length bsk)     putWord8 pv -- must be 3-    putByteString eokeyid -- must be 8 octets+    putByteString (unEOKI eokeyid) -- must be 8 octets     putWord8 $ fromIntegral . fromFVal $ pkalgo     putByteString bsk-putPacket (Signature (SigV3 st ctime eok pka ha left16 mpis)) = do-    putWord8 (0xc0 .|. 2)-    let bs = runPut $ do-                        putWord8 3-                        put st-                        putWord32be ctime-                        putByteString eok-                        put pka-                        put ha-                        putWord16be left16-                        mapM_ put mpis-    putPacketLength . B.length $ bs-    putByteString bs-putPacket (Signature (SigV4 st pka ha hashed unhashed left16 mpis)) = do+putPacket (Signature sp) = do     putWord8 (0xc0 .|. 2)-    let bs = runPut $ do-                        putWord8 4-                        put st-                        put pka-                        put ha-                        let hb = runPut $ mapM_ put hashed-                        putWord16be . fromIntegral . B.length $ hb-                        putByteString hb-                        let ub = runPut $ mapM_ put unhashed-                        putWord16be . fromIntegral . B.length $ ub-                        putByteString ub-                        putWord16be left16-                        mapM_ put mpis+    let bs = runPut $ put sp     putPacketLength . B.length $ bs     putByteString bs putPacket (SKESK pv symalgo s2k msk) = do@@ -619,8 +588,8 @@                 putWord8 $ fromIntegral . fromFVal $ sigtype                 putWord8 $ fromIntegral . fromFVal $ ha                 putWord8 $ fromIntegral . fromFVal $ pka-                putByteString skeyid-                putWord8 . fromIntegral . fromEnum $ nested -- FIXME: what do other values mean?+                putByteString (unEOKI skeyid)+                putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean?     putPacketLength $ B.length bs     putByteString bs putPacket (SecretKey pkp ska) = do@@ -696,28 +665,54 @@     putPacketLength . B.length $ payload     putByteString payload - getMPI :: Get MPI getMPI = do mpilen <- getWord16be             bs <- getByteString ((fromIntegral (mpilen - 1) `div` 8) + 1)-            return $ MPI bs+            return $ MPI (beBSToInteger bs) -getMPIs :: PubKeyAlgorithm -> Get [MPI]-getMPIs RSA = replicateM 2 get-getMPIs RSAEncryptOnly = replicateM 2 get-getMPIs RSASignOnly = replicateM 2 get-getMPIs DSA = replicateM 4 get-getMPIs ElgamalEncryptOnly = replicateM 3 get-getMPIs Elgamal = replicateM 3 get+getPubkey :: PubKeyAlgorithm -> Get PKey+getPubkey RSA = do MPI n <- get+                   MPI e <- get+                   return $ RSAPubKey (R.PublicKey (B.length . integerToBEBS $ n) n e)+getPubkey RSAEncryptOnly = getPubkey RSA+getPubkey RSASignOnly = getPubkey RSA+getPubkey DSA = do MPI p <- get+                   MPI q <- get+                   MPI g <- get+                   MPI y <- get+                   return $ DSAPubKey (D.PublicKey (p, g, q) y)+getPubkey ElgamalEncryptOnly = getPubkey Elgamal+getPubkey Elgamal = do MPI p <- get+                       MPI g <- get+                       MPI y <- get+                       return $ ElGamalPubKey [p,g,y] -getSecretMPIs :: PubKeyAlgorithm -> Get [MPI]-getSecretMPIs RSA = replicateM 4 get-getSecretMPIs RSAEncryptOnly = replicateM 4 get-getSecretMPIs RSASignOnly = replicateM 1 get-getSecretMPIs DSA = replicateM 1 get-getSecretMPIs ElgamalEncryptOnly = replicateM 1 get-getSecretMPIs Elgamal = replicateM 1 get+pubkeyToMPIs :: PKey -> [MPI]+pubkeyToMPIs (RSAPubKey k) = [MPI (R.public_n k), MPI (R.public_e k)]+pubkeyToMPIs (DSAPubKey k) = (\(p,g,q) y -> [MPI p,MPI q,MPI g,MPI y]) (D.public_params k) (D.public_y k)+pubkeyToMPIs (ElGamalPubKey k) = fmap MPI k +putPubkey :: PKey -> Put+putPubkey p = mapM_ put (pubkeyToMPIs p)++getSecretKey :: PubKeyAlgorithm -> Get SKey+getSecretKey RSA = do MPI d <- get+                      MPI p <- get+                      MPI q <- get+                      MPI u <- get+                      let n = p * q+                      let dP = 0+                      let dQ = 0+                      let qinv = 0+                      return $ RSAPrivateKey (R.PrivateKey 0 n d p q dP dQ qinv)+getSecretKey RSAEncryptOnly = getSecretKey RSA+getSecretKey RSASignOnly = getSecretKey RSA+getSecretKey DSA = do MPI x <- get+                      return $ DSAPrivateKey (D.PrivateKey (0,0,0) x)+getSecretKey ElgamalEncryptOnly = getSecretKey Elgamal+getSecretKey Elgamal = do MPI x <- get+                          return $ ElGamalPrivateKey [x]+ indefiniteMPIs :: ByteString -> [MPI] indefiniteMPIs bs = do     case runGet (many getMPI) bs of@@ -725,41 +720,42 @@         Right mpis -> mpis  putMPI :: MPI -> Put-putMPI (MPI bs) = do putWord16be . (*8) . fromIntegral . B.length $ bs -- FIXME: odd bits-                     putByteString bs+putMPI (MPI i) = do let bs = integerToBEBS i+                    putWord16be . countBits $ bs+                    putByteString bs -getPackets :: Get [Packet]-getPackets = many getPacket+getPackets :: Get (Block Packet)+getPackets = Block `fmap` many getPacket -putPackets :: [Packet] -> Put-putPackets = mapM_ putPacket+putPackets :: Block Packet -> Put+putPackets = mapM_ putPacket . unBlock  getPKPayload :: Get PKPayload getPKPayload = do     version <- getWord8     ctime <- getWord32be-    case version `elem` [2,3] of-                               True -> do v3exp <-  getWord16be-                                          pka <- get-                                          mpis <- getMPIs pka-                                          return $ PubV3 ctime v3exp pka mpis-                               False -> do-                                          pka <- get-                                          mpis <- getMPIs pka-                                          return $ PubV4 ctime pka mpis+    if version `elem` [2,3] then+        do v3exp <-  getWord16be+           pka <- get+           pk <- getPubkey pka+           return $ PubV3 ctime v3exp pka pk+    else+        do pka <- get+           pk <- getPubkey pka+           return $ PubV4 ctime pka pk  putPKPayload :: PKPayload -> Put-putPKPayload (PubV3 ctime v3exp pka mpis) = do+putPKPayload (PubV3 ctime v3exp pka pk) = do     putWord8 3     putWord32be ctime     putWord16be v3exp     put pka-    mapM_ put mpis-putPKPayload (PubV4 ctime pka mpis) = do+    putPubkey pk+putPKPayload (PubV4 ctime pka pk) = do     putWord8 4     putWord32be ctime     put pka-    mapM_ put mpis+    putPubkey pk  pubKeyAlgo :: PKPayload -> PubKeyAlgorithm pubKeyAlgo (PubV3 _ _ pka _) = pka@@ -769,9 +765,9 @@ getSKAddendum pka = do     s2kusage <- getWord8     case s2kusage of-        0 -> do mpis <- getSecretMPIs pka+        0 -> do sk <- getSecretKey pka                 checksum <- getWord16be-                return $ SUUnencrypted mpis checksum+                return $ SUUnencrypted sk checksum         255 -> do symenc <- getWord8                   s2k <- getS2K                   iv <- getByteString (symEncBlockSize . toFVal $ symenc)@@ -814,6 +810,71 @@  encodeIterationCount :: Int -> Word8 encodeIterationCount c = fromIntegral c -- FIXME++getSignaturePayload :: Get SignaturePayload+getSignaturePayload = do+    pv <- getWord8+    case pv of+        3 -> do+            hashlen <- getWord8 -- must be 5+            st <- getWord8+            ctime <- getWord32be+            eok <- getByteString 8+            pka <- get+            ha <- get+            left16 <- getWord16be+            remainder <- remaining+            mpib <- getBytes remainder+            case runGet (many getMPI) mpib of+                Left e -> error e+                Right mpis -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 mpis+        4 -> do+            st <- getWord8+            pka <- get+            ha <- get+            hlen <- getWord16be+            hb <- getBytes (fromIntegral hlen)+            let hashed = case runGet (many getSigSubPacket) hb of+                            Left err -> error err+                            Right h -> h+            ulen <- getWord16be+            ub <- getBytes (fromIntegral ulen)+            let unhashed = case runGet (many getSigSubPacket) ub of+                            Left err -> error err+                            Right u -> u+            left16 <- getWord16be+            remainder <- remaining+            mpib <- getBytes remainder+            case runGet (many getMPI) mpib of+                    Left e -> error e+                    Right mpis -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 mpis+        otherwise -> do+            remainder <- remaining+            bs <- getByteString remainder+            return $ SigVOther pv bs++putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do+    putWord8 3+    put st+    putWord32be ctime+    putByteString (unEOKI eok)+    put pka+    put ha+    putWord16be left16+    mapM_ put mpis+putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do+    putWord8 4+    put st+    put pka+    put ha+    let hb = runPut $ mapM_ put hashed+    putWord16be . fromIntegral . B.length $ hb+    putByteString hb+    let ub = runPut $ mapM_ put unhashed+    putWord16be . fromIntegral . B.length $ ub+    putByteString ub+    putWord16be left16+    mapM_ put mpis  -- Stolen from Axman6 many :: Get a -> Get [a]

@@ -0,0 +1,95 @@+-- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes+-- Copyright Ⓒ 2012  Clint Adams+-- This software is released under the terms of the Expat (MIT) license.+-- (See the LICENSE file).++module Codec.Encryption.OpenPGP.SerializeForSigs (+   putPKPforFingerprinting+ , putPartialSigforSigning+ , putSigTrailer+ , putUIDforSigning+ , putUAtforSigning+ , putKeyforSigning+ , putSigforSigning+-- , putSigforSigning+) where++import Control.Applicative ((<$>),(<*>))+import Control.Monad (replicateM, mplus, when)+import qualified Crypto.Cipher.RSA as R+import qualified Crypto.Cipher.DSA as D+import Data.Bits ((.&.), (.|.), shiftL, shiftR)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC8+import Data.List (mapAccumL)+import Data.Maybe (isJust, fromJust)+import Data.Serialize (Serialize, get, put)+import Data.Serialize.Get (Get, getWord8, getWord16be, getWord32be, getBytes, getByteString, getWord16le, runGet, remaining)+import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putWord16le, runPut)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Word (Word8, Word16)++import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS)+import Codec.Encryption.OpenPGP.Serialize ()+import Codec.Encryption.OpenPGP.Types++putPKPforFingerprinting :: Packet -> Put -- FIXME+putPKPforFingerprinting (PublicKey pkp) = do+    putWord8 (0x99)+    let bs = runPut $ put pkp+    putWord16be . fromIntegral $ B.length bs+    putByteString bs++putPartialSigforSigning :: Packet -> Put+putPartialSigforSigning (Signature (SigV4 st pka ha hashed unhashed left16 mpis)) = do+    putWord8 4+    put st+    put pka+    put ha+    let hb = runPut $ mapM_ put hashed+    putWord16be . fromIntegral . B.length $ hb+    putByteString hb++putSigTrailer :: Packet -> Put+putSigTrailer (Signature (SigV4 _ _ _ hs _ _ _)) = do+            putWord8 0x04+            putWord8 0xff+            putWord32be . fromIntegral . (+6) . B.length $ (runPut $ mapM_ put hs)+            -- this +6 seems like a bug in RFC4880++putUIDforSigning :: Packet -> Put+putUIDforSigning (UserId u) = do+    putWord8 0xB4+    let bs = BC8.pack u+    putWord32be . fromIntegral . B.length $ bs+    putByteString bs++putUAtforSigning :: Packet -> Put+putUAtforSigning (UserAttribute us) = do+    putWord8 0xD1+    let bs = B.empty -- FIXME: what gets hashed?+    putWord32be . fromIntegral . B.length $ bs+    putByteString bs++putSigforSigning :: Packet -> Put+putSigforSigning (Signature (SigV4 st pka ha hashed _ left16 mpis)) = do+    putWord8 0x88+    let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)+    putWord32be . fromIntegral . B.length $ bs+    putByteString bs++putKeyforSigning :: Packet -> Put+putKeyforSigning (PublicKey pkp) = putKeyForSigning' pkp Nothing+putKeyforSigning (PublicSubkey pkp) = putKeyForSigning' pkp Nothing+putKeyforSigning (SecretKey pkp ska) = putKeyForSigning' pkp (Just ska)+putKeyforSigning (SecretSubkey pkp ska) = putKeyForSigning' pkp (Just ska)++putKeyForSigning' :: PKPayload -> Maybe SKAddendum -> Put+putKeyForSigning' pkp mska = do+    putWord8 0x99+    let bs = runPut $ put pkp+    -- FIXME: add ska+    putWord32be . fromIntegral . B.length $ bs+    putByteString bs

@@ -9,7 +9,7 @@  , HashAlgorithm(..)  , PubKeyAlgorithm(..)  , SymmetricAlgorithm(..)- , MPI(MPI)+ , MPI(..)  , Packet(..)  , S2K(..)  , SignaturePayload(..)@@ -22,20 +22,36 @@  , ArmorType(..)  , Armor(Armor)  , DataType(..)- , EightOctetKeyId+ , PKey(..)+ , SKey(..)+ , EightOctetKeyId(..)+ , TwentyOctetFingerprint(..)+ , TK(..)  , SessionKey  , FutureFlag  , FutureVal  , ArmorHeader+ , Keyring  , fromFVal  , fromFFlag  , toFVal  , toFFlag+ , Block(Block)+ , unBlock ) where +import qualified Crypto.Cipher.RSA as RSA+import qualified Crypto.Cipher.DSA as DSA++import Control.Arrow ((***)) import Data.ByteString (ByteString)+import Data.Char (toLower, toUpper)+import qualified Data.ByteString as B+import Data.List.Split (splitEvery)+import Data.Map (Map) import Data.Set (Set) import Data.Word (Word8, Word16, Word32)+import Numeric (readHex, showHex)  type TimeStamp = Word32 type Exportability = Bool@@ -44,8 +60,6 @@ type AlmostPublicDomainRegex = ByteString type Revocability = Bool type RevocationReason = ByteString-type TwentyOctetFingerprint = ByteString-type EightOctetKeyId = ByteString type KeyServer = ByteString type URL = ByteString type NotationName = ByteString@@ -371,7 +385,7 @@     toFFlag 7 = ModificationDetection     toFFlag i = FeatureOther (fromIntegral i) -data MPI = MPI ByteString+newtype MPI = MPI {unMPI :: Integer}     deriving (Show, Eq)  data SignaturePayload = SigV3 SigType Word32 EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 [MPI]@@ -379,14 +393,14 @@                       | SigVOther Word8 ByteString     deriving (Show, Eq) -- FIXME -data PKPayload = PubV3 TimeStamp V3Expiration PubKeyAlgorithm [MPI]-               | PubV4 TimeStamp PubKeyAlgorithm [MPI]+data PKPayload = PubV3 TimeStamp V3Expiration PubKeyAlgorithm PKey+               | PubV4 TimeStamp PubKeyAlgorithm PKey     deriving (Show, Eq)  data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString                 | SUSSHA1 SymmetricAlgorithm S2K IV ByteString                 | SUSym SymmetricAlgorithm IV ByteString-                | SUUnencrypted [MPI] Word16+                | SUUnencrypted SKey Word16     deriving (Show, Eq)  data DataType = BinaryData@@ -533,3 +547,42 @@  data Armor a = Armor (ArmorType a) [ArmorHeader] [Packet]     deriving (Show, Eq)++data PKey = RSAPubKey RSA.PublicKey+          | DSAPubKey DSA.PublicKey+          | ElGamalPubKey [Integer]+    deriving (Show, Eq)++data SKey = RSAPrivateKey RSA.PrivateKey+          | DSAPrivateKey DSA.PrivateKey+          | ElGamalPrivateKey [Integer]+    deriving (Show, Eq)++newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance+    deriving (Show, Eq)++newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString}+    deriving (Eq, Ord) -- FIXME++instance Show EightOctetKeyId where+    show = w8sToHex . B.unpack . unEOKI++instance Read EightOctetKeyId where+    readsPrec 0 = map ((EightOctetKeyId . B.pack *** concat) . unzip) . splitEvery 8 . hexToW8s++newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString}+    deriving (Eq)++instance Show TwentyOctetFingerprint where+    show = take 50 . concatMap (++" ") . concatMap (++[""]) . splitEvery 5 . splitEvery 4 . w8sToHex . B.unpack . unTOF++w8sToHex :: [Word8] -> String+w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "")++hexToW8s :: ReadS Word8+hexToW8s = concatMap readHex . splitEvery 2 . map toLower++data TK = TPK PKPayload [SignaturePayload] [(String, [SignaturePayload])] [([UserAttrSubPacket], [SignaturePayload])] [(PKPayload, SignaturePayload, Maybe SignaturePayload)] | TSK Packet [SignaturePayload] [(String, [SignaturePayload])] [([UserAttrSubPacket], [SignaturePayload])] [(Packet, SignaturePayload, Maybe SignaturePayload)] | NoTK+    deriving (Eq, Show)++type Keyring = Map EightOctetKeyId TK

@@ -0,0 +1,31 @@+module Data.Conduit.Cereal.Temp (conduitGet)+where++import Control.Exception (throw)+import Control.Monad.Trans+import qualified Data.ByteString as BS+import qualified Data.Conduit as DC+import Data.Conduit.Cereal+import Data.Serialize+import Data.Serialize.Get++conduitGet :: (DC.ResourceThrow m, Serialize output) => Get output -> DC.Conduit BS.ByteString m output+conduitGet f = do+    let acceptable = case runGetPartial f BS.empty of+                 Data.Serialize.Fail s -> throw $ GetException s+                 Data.Serialize.Partial f -> True+                 Data.Serialize.Done _ _ -> throw GetDoesntConsumeInput+    if acceptable then DC.conduitState BS.empty (push f) (close f) else undefined+    where+        push :: (DC.ResourceThrow m, Serialize a) => Get a -> BS.ByteString -> BS.ByteString -> DC.ResourceT m (DC.ConduitStateResult BS.ByteString BS.ByteString a)+        push f state input = (\(as, bs) -> return $ DC.StateProducing bs as) (go f ([], state `BS.append` input))++        close :: (DC.ResourceThrow m, Serialize a) => Get a -> BS.ByteString -> DC.ResourceT m [a]+        close f state = return []++        go :: Serialize a => Get a -> ([a], BS.ByteString) -> ([a], BS.ByteString)+        go f (as, bs)+            | BS.null bs = (as, bs)+            | otherwise = case runGetState f bs 0 of+                              Left err -> (as, bs)+                              Right (a, b) -> go f (as ++ [a], b)

@@ -0,0 +1,23 @@+-- ASCIIArmor.hs: OpenPGP (RFC4880) ASCII armor implementation+-- Copyright Ⓒ 2012  Clint Adams+-- This software is released under the terms of the Expat (MIT) license.+-- (See the LICENSE file).++module Data.Conduit.OpenPGP.Compression (+   conduitCompress+ , conduitDecompress+) where++import Codec.Encryption.OpenPGP.Compression+import Codec.Encryption.OpenPGP.Types+import Data.Conduit+import qualified Data.Conduit.List as CL++conduitCompress :: ResourceThrow m => CompressionAlgorithm -> Conduit Packet m Packet+conduitCompress algo = conduitState [] push (close algo)+    where+        push state input = return $ StateProducing (input : state) []+        close algo state = return $ [compressPackets algo state]++conduitDecompress :: ResourceThrow m => Conduit Packet m Packet+conduitDecompress = CL.concatMap decompressPacket

@@ -0,0 +1,83 @@+-- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing+-- Copyright Ⓒ 2012  Clint Adams+-- This software is released under the terms of the Expat (MIT) license.+-- (See the LICENSE file).++module Data.Conduit.OpenPGP.Keyring (+   conduitToTKs+ , sinkKeyringMap+) where++import qualified Data.ByteString as B+import Data.Conduit++import Data.Map (Map)+import qualified Data.Map as Map++import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID)+import Codec.Encryption.OpenPGP.Types++data Phase = MainKey | Revs | Uids | UAts | Subs+    deriving (Eq, Ord, Show)++conduitToTKs :: Resource m => Conduit Packet m TK+conduitToTKs = conduitState (MainKey, NoTK) push close+    where+        push state input = case (state, input) of+                               ((MainKey, _), PublicKey pkp) -> return $ StateProducing (Revs, TPK pkp [] [] [] []) []+                               ((MainKey, _), SecretKey pkp ska) -> return $ StateProducing (Revs, TSK (SecretKey pkp ska) [] [] [] []) []+                               ((Revs, TPK pkp revs uids uats subs), Signature s) -> return $ StateProducing (Revs, TPK pkp (revs ++ [s]) uids uats subs) []+                               ((Revs, TPK pkp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TPK pkp revs [(u, [])] uats subs) []+                               ((Uids, TPK pkp revs uids uats subs), Signature s) -> return $ StateProducing (Uids, TPK pkp revs (addUidSig s uids) uats subs) []+                               ((Uids, TPK pkp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TPK pkp revs (uids ++ [(u, [])]) uats subs) []+                               ((Uids, TPK pkp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TPK pkp revs uids [(u, [])] subs) []+                               ((Uids, TPK pkp revs uids uats subs), PublicSubkey p) -> return $ StateProducing (Subs, TPK pkp revs uids uats [(p, SigVOther 0 B.empty, Nothing)]) []+                               ((Uids, TPK pkp revs uids uats subs), PublicKey p) -> return $ StateProducing (Revs, TPK p [] [] [] []) [TPK pkp revs uids uats subs]+                               ((UAts, TPK pkp revs uids uats subs), Signature s) -> return $ StateProducing (UAts, TPK pkp revs uids (addUAtSig s uats) subs) []+                               ((UAts, TPK pkp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TPK pkp revs uids (uats ++ [(u, [])]) subs) []+                               ((UAts, TPK pkp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TPK pkp revs (uids ++ [(u, [])]) uats subs) []+                               ((UAts, TPK pkp revs uids uats subs), PublicSubkey p) -> return $ StateProducing (Subs, TPK pkp revs uids uats [(p, SigVOther 0 B.empty, Nothing)]) []+                               ((UAts, TPK pkp revs uids uats subs), PublicKey p) -> return $ StateProducing (Revs, TPK p [] [] [] []) [TPK pkp revs uids uats subs]+                               ((Subs, TPK pkp revs uids uats subs), PublicSubkey p) -> return $ StateProducing (Subs, TPK pkp revs uids uats (subs ++ [(p, SigVOther 0 B.empty, Nothing)])) []+                               ((Subs, TPK pkp revs uids uats subs), Signature s) -> case sType s of+                                                                                        SubkeyBindingSig -> return $ StateProducing (Subs, TPK pkp revs uids uats (setBSig s subs)) []+                                                                                        SubkeyRevocationSig -> return $ StateProducing (Subs, TPK pkp revs uids uats (setRSig s subs)) []+                                                                                        otherwise -> error $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input+                               ((Subs, TPK pkp revs uids uats subs), PublicKey p) -> return $ StateProducing (Revs, TPK p [] [] [] []) [TPK pkp revs uids uats subs]+                               ((Revs, TSK skp revs uids uats subs), Signature s) -> return $ StateProducing (Revs, TSK skp (revs ++ [s]) uids uats subs) []+                               ((Revs, TSK skp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TSK skp revs [(u, [])] uats subs) []+                               ((Uids, TSK skp revs uids uats subs), Signature s) -> return $ StateProducing (Uids, TSK skp revs (addUidSig s uids) uats subs) []+                               ((Uids, TSK skp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TSK skp revs (uids ++ [(u, [])]) uats subs) []+                               ((Uids, TSK skp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TSK skp revs uids [(u, [])] subs) []+                               ((Uids, TSK skp revs uids uats subs), SecretSubkey p s) -> return $ StateProducing (Subs, TSK skp revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]) []+                               ((Uids, TSK skp revs uids uats subs), SecretKey p s) -> return $ StateProducing (Revs, TSK (SecretKey p s) [] [] [] []) [TSK skp revs uids uats subs]+                               ((UAts, TSK skp revs uids uats subs), Signature s) -> return $ StateProducing (UAts, TSK skp revs uids (addUAtSig s uats) subs) []+                               ((UAts, TSK skp revs uids uats subs), UserAttribute u) -> return $ StateProducing (UAts, TSK skp revs uids (uats ++ [(u, [])]) subs) []+                               ((UAts, TSK skp revs uids uats subs), UserId u) -> return $ StateProducing (Uids, TSK skp revs (uids ++ [(u, [])]) uats subs) []+                               ((UAts, TSK skp revs uids uats subs), SecretSubkey p s) -> return $ StateProducing (Subs, TSK skp revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]) []+                               ((UAts, TSK skp revs uids uats subs), SecretKey p s) -> return $ StateProducing (Revs, TSK (SecretKey p s) [] [] [] []) [TSK skp revs uids uats subs]+                               ((Subs, TSK skp revs uids uats subs), SecretSubkey p s) -> return $ StateProducing (Subs, TSK skp revs uids uats (subs ++ [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) []+                               ((Subs, TSK skp revs uids uats subs), Signature s) -> case sType s of+                                                                                        SubkeyBindingSig -> return $ StateProducing (Subs, TSK skp revs uids uats (setBSig s subs)) []+                                                                                        SubkeyRevocationSig -> return $ StateProducing (Subs, TSK skp revs uids uats (setRSig s subs)) []+                                                                                        otherwise -> error $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input+                               ((Subs, TSK skp revs uids uats subs), SecretKey p s) -> return $ StateProducing (Revs, TSK (SecretKey p s) [] [] [] []) [TSK skp revs uids uats subs]+                               ((_,_), Trust _) -> return $ StateProducing state []+                               otherwise -> error $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input+        close (_, tk) = return [tk]+        addUidSig s uids = init uids ++ [(\(u, us) -> (u, us ++ [s])) (last uids)]+        addUAtSig s uats = init uats ++ [(\(u, us) -> (u, us ++ [s])) (last uats)]+        setBSig s subs = init subs ++ [(\(p, b, r) -> (p, s, r)) (last subs)]+        setRSig s subs = init subs ++ [(\(p, b, r) -> (p, b, Just s)) (last subs)]+        sType (SigV3 st _ _ _ _ _ _) = st+        sType (SigV4 st _ _ _ _ _ _) = st+++sinkKeyringMap :: Resource m => Sink TK m (Map EightOctetKeyId TK)+sinkKeyringMap = sinkState Map.empty push close+    where+        push :: Resource m => Map EightOctetKeyId TK -> TK -> ResourceT m (SinkStateResult (Map EightOctetKeyId TK) TK (Map EightOctetKeyId TK))+        push state input = return $ StateProcessing $ Map.insert (eok input) input state+        close state = return state+        eok (TPK pkp _ _ _ _) = eightOctetKeyID pkp+        eok (TSK (SecretKey p s) _ _ _ _) = eightOctetKeyID p

@@ -0,0 +1,158 @@+-- Verify.hs: OpenPGP (RFC4880) signature verification+-- Copyright Ⓒ 2012  Clint Adams+-- This software is released under the terms of the Expat (MIT) license.+-- (See the LICENSE file).++module Data.Conduit.OpenPGP.Verify (+   conduitVerify+) where++import qualified Crypto.Cipher.DSA as DSA+import qualified Crypto.Cipher.RSA as RSA++import qualified Crypto.Hash.RIPEMD160 as RIPEMD160+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA224 as SHA224+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Hash.SHA384 as SHA384+import qualified Crypto.Hash.SHA512 as SHA512++import qualified Data.ASN1.DER as DER+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Lazy as BL+import Data.Conduit+import Data.List (find)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Serialize.Put (runPut)++import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID)+import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS)+import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, putKeyforSigning, putSigforSigning)+import Codec.Encryption.OpenPGP.Types++data StreamState = StreamState { lastLD :: Packet+                               , lastUIDorUAt :: Packet+                               , lastSig :: Packet+                               , lastPrimaryKey :: Packet+                               , lastSubkey :: Packet+                               }++conduitVerify :: Resource m => Keyring -> Conduit Packet m (Either String Bool)+conduitVerify kr = conduitState (StreamState (Marker B.empty) (Marker B.empty) (Marker B.empty) (Marker B.empty) (Marker B.empty)) push close+    where+        push state ld@(LiteralData _ _ _ _) = return $ StateProducing (state { lastLD = ld }) []+        push state uid@(UserId _) = return $ StateProducing (state { lastUIDorUAt = uid }) []+        push state uat@(UserAttribute _) = return $ StateProducing (state { lastUIDorUAt = uat }) []+        push state pk@(PublicKey _) = return $ StateProducing (state { lastPrimaryKey = pk }) []+        push state pk@(PublicSubkey _) = return $ StateProducing (state { lastSubkey = pk }) []+        push state sk@(SecretKey _ _) = return $ StateProducing (state { lastPrimaryKey = sk }) []+        push state sk@(SecretSubkey _ _) = return $ StateProducing (state { lastSubkey = sk }) []+        push state sig@(Signature (SigV4 _ _ _ _ _ _ _)) = return $ StateProducing state { lastSig = sig } [verifySig kr sig state]+        push state (OnePassSignature pv st ha pka eok False) = return $ StateProducing state []+        push state input = return $ StateProducing state []+        close state = return []+        normLineEndings = id  -- FIXME++verifySig kr sig@(Signature (SigV4 BinarySig pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastLD state)+verifySig kr sig@(Signature (SigV4 CanonicalTextSig pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastLD state)+verifySig kr sig@(Signature (SigV4 StandaloneSig pka ha hsubs usubs left16 mpis)) state = verify kr sig (Marker B.empty)+verifySig kr sig@(Signature (SigV4 GenericCert pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastUIDorUAt state)+verifySig kr sig@(Signature (SigV4 PersonaCert pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastUIDorUAt state)+verifySig kr sig@(Signature (SigV4 CasualCert pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastUIDorUAt state)+verifySig kr sig@(Signature (SigV4 PositiveCert pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastUIDorUAt state)+verifySig kr sig@(Signature (SigV4 SubkeyBindingSig pka ha hsubs usubs left16 mpis)) state = Left "FIXME: SubkeyBindingSig"+verifySig kr sig@(Signature (SigV4 PrimaryKeyBindingSig pka ha hsubs usubs left16 mpis)) state = Left "FIXME: PrimaryKeyBindingSig"+verifySig kr sig@(Signature (SigV4 SignatureDirectlyOnAKey pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastPrimaryKey state)+verifySig kr sig@(Signature (SigV4 KeyRevocationSig pka ha hsubs usubs left16 mpis)) state = Left "FIXME: KeyRevocationSig"+verifySig kr sig@(Signature (SigV4 SubkeyRevocationSig pka ha hsubs usubs left16 mpis)) state = Left "FIXME: SubkeyRevocationSig"+verifySig kr sig@(Signature (SigV4 CertRevocationSig pka ha hsubs usubs left16 mpis)) state = verify kr sig (lastSig state)+verifySig kr sig@(Signature (SigV4 st pka ha hsubs usubs left16 mpis)) state = Left ("I dunno how to " ++ show st)++verify kr sig (LiteralData dt fn ts bs) = go kr sig bs+verify kr sig (UserId uid) = go kr sig (B.singleton 0xB4 `B.append` BC8.pack uid)+verify kr sig (UserAttribute uats) = go kr sig (B.empty) -- FIXME: proper serialization of uats+verify kr sig (Marker _) = go kr sig (B.empty) -- fake for standalone sig+verify kr sig p@(PublicKey _) = go kr sig (runPut $ putKeyforSigning p)+verify kr sig p@(PublicSubkey _) = go kr sig (runPut $ putKeyforSigning p)+verify kr sig p@(SecretKey _ _) = go kr sig (runPut $ putKeyforSigning p)+verify kr sig p@(SecretSubkey _ _) = go kr sig (runPut $ putKeyforSigning p)+verify kr sig s@(Signature _) = go kr sig (runPut $ putSigforSigning s)+verify kr sig p = Left $ "So confused..." ++ show p++go kr sig payload = case issuer sig of+                            Nothing -> Left "pubkey not found"+                            Just i -> verify' (Map.lookup i kr) sig payload+    where+        verify' Nothing _ _ = Left "pubkey not found"+        verify' (Just tpk) sig payload = verify'' sig tpk (hashalgo sig) (finalPayload sig payload)+        verify'' (Signature (SigV4 _ pka _ _ _ _ mpis)) (TPK (PubV4 _ _ pkey) _ _ _ _) hashalgo pl = verify''' pka hashalgo mpis pkey pl+        verify''' DSA hashalgo mpis (DSAPubKey pkey) bs = case DSA.verify (dsaMPIsToSig mpis) (dsaTruncate pkey . (hash hashalgo)) pkey bs of+                                                             Left err -> Left "invalid signature"+                                                             Right False -> Left $ "verification failed"+                                                             Right True -> Right True+        verify''' RSA hashalgo mpis (RSAPubKey pkey) bs = case RSA.verify (hash hashalgo) (asn1Prefix hashalgo) pkey bs (rsaMPItoSig mpis) of+                                                             Left err -> Left "invalid signature"+                                                             Right False -> Left $ "verification failed"+                                                             Right True -> Right True+        dsaMPIsToSig mpis = (unMPI (mpis !! 0), unMPI (mpis !! 1))+        rsaMPItoSig mpis = integerToBEBS (unMPI (mpis !! 0))+        finalPayload sig payload = payload `B.append` sigbit sig `B.append` trailer sig+        sigbit sig = runPut $ putPartialSigforSigning sig+        hashalgo (Signature (SigV4 _ _ ha _ _ _ _)) = ha+        trailer sig@(Signature (SigV4 _ _ _ hs _ _ _)) = runPut $ putSigTrailer sig+        dsaTruncate pkey bs = if countBits bs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits+        dsaQLen pk = (\(x,y,z) -> countBits (integerToBEBS z)) (DSA.public_params pk)++issuer (Signature (SigV4 st pka ha hsubs usubs left16 mpis)) = fmap (\(Issuer _ i) -> i) (find (isIssuer) usubs)+    where+        isIssuer (Issuer _ _) = True+        isIssuer _ = False++hash SHA1 = SHA1.hash+hash RIPEMD160 = RIPEMD160.hash+hash SHA256 = SHA256.hash+hash SHA384 = SHA384.hash+hash SHA512 = SHA512.hash+hash SHA224 = SHA224.hash++--emsa_pkcs1_v1_5_encode :: HashAlgorithm -> ByteString -> Int -> Either String ByteString+--emsa_pkcs1_v1_5_encode ha m emLen = if emLen < tLen + 11 then+--                                        Left "intended encoded message length too short"+--                                    else+--                                        Right $ B.concat [header, ps, numpty, t]+--    where+--        t = asn1DigestInfo ha (hash ha m)+--        tLen = B.length t+--        header = B.pack [0,1]+--        ps = B.pack $ replicate (emLen - tLen - 3) 0xff+--        numpty = B.singleton 0++asn1Prefix :: HashAlgorithm -> ByteString+asn1Prefix ha = do+    let start = DER.Start DER.Sequence+    let (blen, oid) = (bitLength ha, hashOid ha)+    let numpty = DER.Null+    let end = DER.End DER.Sequence+    let fakeint = DER.OctetString (BL.pack (replicate ((blen `div` 8) - 1) 0 ++ [1]))+    case DER.encodeASN1Stream [start,start,oid,numpty,end,fakeint,end] of+        Left err -> error "encodeASN1 failure"+        Right l -> B.concat . BL.toChunks $ getPrefix l+    where+        getPrefix = BL.reverse . BL.drop 1 . BL.dropWhile (==0) . BL.reverse+        bitLength DeprecatedMD5 = 128+        bitLength SHA1 = 160+        bitLength RIPEMD160 = 160+        bitLength SHA256 = 256+        bitLength SHA384 = 384+        bitLength SHA512 = 512+        bitLength SHA224 = 224+        hashOid DeprecatedMD5 = DER.OID [1,2,840,113549,2,5]+        hashOid RIPEMD160 = DER.OID [1,3,36,3,2,1]+        hashOid SHA1 = DER.OID [1,3,14,3,2,26]+        hashOid SHA224 = DER.OID [2,16,840,1,101,3,4,2,4]+        hashOid SHA256 = DER.OID [2,16,840,1,101,3,4,2,1]+        hashOid SHA384 = DER.OID [2,16,840,1,101,3,4,2,2]+        hashOid SHA512 = DER.OID [2,16,840,1,101,3,4,2,3]

@@ -1,5 +1,5 @@ Name:                hOpenPGP-Version:             0.1+Version:             0.2 Synopsis:            native Haskell implementation of OpenPGP (RFC4880) Description:         native Haskell implementation of OpenPGP (RFC4880) Homepage:            http://floss.scru.org/hOpenPGP/@@ -91,7 +91,10 @@   , tests/data/000078-012.ring_trust   , tests/data/pubring.gpg   , tests/data/secring.gpg+  , tests/data/compressedsig.gpg   , tests/data/msg1.asc+  , tests/data/uncompressed-ops-rsa.gpg+  , tests/data/uncompressed-ops-dsa.gpg  Cabal-version:       >= 1.10 @@ -100,27 +103,53 @@   Exposed-modules:     Codec.Encryption.OpenPGP.Types                      , Codec.Encryption.OpenPGP.Serialize                      , Codec.Encryption.OpenPGP.ASCIIArmor+                     , Codec.Encryption.OpenPGP.Compression+                     , Codec.Encryption.OpenPGP.Fingerprint+                     , Data.Conduit.OpenPGP.Compression+                     , Data.Conduit.OpenPGP.Keyring+                     , Data.Conduit.OpenPGP.Verify   Other-Modules: Data.Digest.CRC24+               , Codec.Encryption.OpenPGP.Internal                , Codec.Encryption.OpenPGP.ASCIIArmor.Decode                , Codec.Encryption.OpenPGP.ASCIIArmor.Encode-  Build-depends: attoparsec+               , Codec.Encryption.OpenPGP.SerializeForSigs+               , Data.Conduit.Cereal.Temp+  Build-depends: asn1-data+               , attoparsec                , base                  > 4       && < 5                , base64-bytestring                , bytestring+               , bzlib                , cereal+               , cereal-conduit                     < 0.0.4+               , conduit                            < 0.3.0                , containers+               , cryptocipher+               , cryptohash+               , mtl+               , split+               , zlib   default-language: Haskell2010   Test-Suite tests   type:       exitcode-stdio-1.0   main-is:    tests/suite.hs-  Build-depends: attoparsec+  Build-depends: asn1-data+               , attoparsec                , base                  > 4       && < 5                , base64-bytestring                , bytestring+               , bzlib                , cereal+               , cereal-conduit                     < 0.0.4+               , conduit                            < 0.3.0                , containers+               , cryptocipher+               , cryptohash+               , mtl+               , split+               , zlib                , HUnit                , test-framework                , test-framework-hunit

binary file changed (absent → 324 bytes)

binary file changed (absent → 150 bytes)

binary file changed (absent → 236 bytes)

@@ -5,25 +5,43 @@  import Test.HUnit -import Codec.Encryption.OpenPGP.Serialize (getPackets, putPackets)+import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.ASCIIArmor (armor, decodeArmor)+import Codec.Encryption.OpenPGP.Compression (decompressPacket, compressPackets)+import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Types+import Data.Conduit.Cereal.Temp (conduitGet)+import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress)+import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap)+import Data.Conduit.OpenPGP.Verify (conduitVerify)+ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Digest.CRC24 (crc24)-import Data.Serialize.Get (runGet)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Serialize (get, put)+import Data.Serialize.Get (runGet, Get) import Data.Serialize.Put (runPut) import Data.Word (Word32) +import qualified Data.Conduit as DC+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+ testSerialization :: FilePath -> Assertion testSerialization fp = do     bs <- B.readFile $ "tests/data/" ++ fp-    let firstpass = runGet getPackets bs-    case firstpass of+    let firstpass = runGet get bs+    case fmap unBlock firstpass of         Left err -> assertFailure $ "First pass failed on " ++ fp-        Right packs -> do let roundtrip = runPut $ putPackets packs-                          let secondpass = runGet getPackets roundtrip-                          assertEqual ("for " ++ fp) firstpass secondpass+        Right [] -> assertFailure $ "First pass of " ++ fp ++ " decoded to nothing."+        Right packs -> do let roundtrip = runPut $ put (Block packs)+                          let secondpass = runGet (get :: Get (Block Packet)) roundtrip+                          if fmap unBlock secondpass == Right [] then+                              assertFailure $ "Second pass of " ++ fp ++ " decoded to nothing."+                          else+                              assertEqual ("for " ++ fp) firstpass secondpass  testCRC24 :: ByteString -> Word32 -> Assertion testCRC24 bs crc = assertEqual "crc24" crc (crc24 bs)@@ -38,6 +56,47 @@ testArmorEncode :: Armor Int -> ByteString -> Assertion testArmorEncode arm target = assertEqual ("literaldata") (armor arm) target +testCompression :: FilePath -> Assertion+testCompression fp = do+    bs <- B.readFile $ "tests/data/" ++ fp+    let firstpass = fmap (concatMap decompressPacket) . fmap unBlock . runGet get $ bs+    case firstpass of+        Left err -> assertFailure $ "First pass failed on " ++ fp+        Right [] -> assertFailure $ "First pass of " ++ fp ++ " decoded to nothing."+        Right packs -> do let roundtrip = runPut $ put . Block $ [compressPackets ZIP packs]+                          let secondpass = fmap (concatMap decompressPacket) . fmap unBlock . runGet get $ roundtrip+                          if secondpass == Right [] then+                              assertFailure $ "Second pass of " ++ fp ++ " decoded to nothing."+                          else+                              assertEqual ("for " ++ fp) firstpass secondpass++counter :: (DC.ResourceIO m) => DC.Sink a m Int+counter = CL.fold (const . (1+)) 0++testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString IO b -> Int -> Assertion+testConduitOutputLength fp c target = do+    len <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fp) DC.$= c DC.$$ counter+    assertEqual ("expected length" ++ show target) target len++testKeyIDandFingerprint :: FilePath -> String -> Assertion+testKeyIDandFingerprint fp kf = do+    bs <- B.readFile $ "tests/data/" ++ fp+    case runGet (get :: Get Packet) bs of+        Left err -> assertFailure $ "Decoding of " ++ fp ++ " broke."+        Right (PublicKey pkp) -> assertEqual ("for " ++ fp) kf (show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp))++testKeyringLookup :: FilePath -> String -> Bool -> Assertion+testKeyringLookup fp eok expected = do+    kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fp) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap+    let key = (Map.lookup (read eok) kr)+    assertEqual (eok ++ " in " ++ fp) expected (isJust key)++testVerifyMessage :: FilePath -> FilePath -> Assertion+testVerifyMessage keyring message = do+    kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ keyring) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap+    verification <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr DC.$$ CL.consume+    assertEqual (keyring ++ " for " ++ message) ([Right True]) verification+ tests = [   testGroup "Serialization group" [      testCase "000001-006.public_key" (testSerialization "000001-006.public_key")@@ -120,6 +179,12 @@    , testCase "000078-012.ring_trust" (testSerialization "000078-012.ring_trust")    , testCase "pubring.gpg" (testSerialization "pubring.gpg")    , testCase "secring.gpg" (testSerialization "secring.gpg")+   , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg")+   , testCase "compressedsig-zlib.gpg" (testSerialization "compressedsig-zlib.gpg")+   , testCase "compressedsig-bzip2.gpg" (testSerialization "compressedsig-bzip2.gpg")+   , testCase "onepass_sig" (testSerialization "onepass_sig")+   , testCase "uncompressed-ops-dsa.gpg" (testSerialization "uncompressed-ops-dsa.gpg")+   , testCase "uncompressed-ops-rsa.gpg" (testSerialization "uncompressed-ops-rsa.gpg")    ],   testGroup "CRC24 group" [      testCase "CRC24: A" (testCRC24 "A" 16680698)@@ -129,60 +194,38 @@   testGroup "ASCII armor group" [      testCase "Decode sample armor" (testArmorDecode "msg1.asc" (Armor ArmorMessage [("Version","OpenPrivacy 0.99")] [CompressedData ZIP ";m\150\196\DC1\239\236\239\ETB\236\239\227\202\NUL\EOT\206\137y\234%\n\137y\149\249y\169\n\217\169\169\ENQ\n\137\n\197\169\201E\169@\193\162\252\210\188\DC4\133\140\212\162T{.\NUL"]))    , testCase "Encode sample armor" (testArmorEncode (Armor ArmorMessage [("Comment", "Test")] [LiteralData UTF8Data "notlob.txt" 12345 "These are the days of literal data.\n"]) "-----BEGIN PGP MESSAGE-----\nComment: Test\n\nyzR1Cm5vdGxvYi50eHQAADA5VGhlc2UgYXJlIHRoZSBkYXlzIG9mIGxpdGVyYWwgZGF0YS4K\n=AAKY\n-----END PGP MESSAGE-----\n")+   ],+  testGroup "Compression group" [+     testCase "compressedsig.gpg" (testCompression "compressedsig.gpg")+   , testCase "compressedsig-zlib.gpg" (testCompression "compressedsig-zlib.gpg")+   , testCase "compressedsig-bzip2.gpg" (testCompression "compressedsig-bzip2.gpg")+   ],+  testGroup "Conduit group" [+     testCase "compressedsig straight" (testConduitOutputLength "compressedsig.gpg" (conduitGet (get :: Get Packet)) 1)+   , testCase "compressedsig uncompressed" (testConduitOutputLength "compressedsig.gpg" (conduitGet (get :: Get Packet) DC.=$= conduitDecompress) 3)+   , testCase "pubring" (testConduitOutputLength "pubring.gpg" (conduitGet (get :: Get Packet)) 46)+   ],+  testGroup "Fingerprint group" [+     testCase "000001-006.public_key" (testKeyIDandFingerprint "000001-006.public_key" "D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E")+   , testCase "000016-006.public_key" (testKeyIDandFingerprint "000016-006.public_key" "5E9F1523413262DC/AF95 E4D7 BAC5 21EE 9740  BED7 5E9F 1523 4132 62DC")+   , testCase "000027-006.public_key" (testKeyIDandFingerprint "000027-006.public_key" "7732CF988A63EA86/1EB2 0B2F 5A5C C3BE AFD6  E5CB 7732 CF98 8A63 EA86")+   , testCase "000035-006.public_key" (testKeyIDandFingerprint "000035-006.public_key" "DEDC3ECF689AF56D/CB79 3345 9F59 C70D F1C3  FBEE DEDC 3ECF 689A F56D")+   ],+  testGroup "Keyring group" [+     testCase "pubring 7732CF988A63EA86" (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True)+   , testCase "pubring 123456789ABCDEF0" (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False)+   , testCase "secring 7732CF988A63EA86" (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True)+   , testCase "secring 123456789ABCDEF0" (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False)+   -- FIXME: should count keys in rings+   ],+  testGroup "Message verification group" [+     testCase "uncompressed-ops-dsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa.gpg")+   , testCase "uncompressed-ops-dsa-sha384" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa-sha384.txt.gpg")+   -- , testCase "uncompressed-ops-rsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-rsa.gpg")+   -- , testCase "compressedsig" (testVerifyMessage "pubring.gpg" "compressedsig.gpg")+   -- , testCase "compressedsig-zlib" (testVerifyMessage "pubring.gpg" "compressedsig-zlib.gpg")+   -- , testCase "compressedsig-bzip2" (testVerifyMessage "pubring.gpg" "compressedsig-bzip2.gpg")    ]  ]---- main = runTestTT tests---- specs :: Specs--- specs = describe "Round-trip serialization" [it "000001-006.public_key" (testSerialization "000001-006.public_key")---   , it "000002-013.user_id" (testSerialization "000002-013.user_id")---   , it "000003-002.sig" (testSerialization "000003-002.sig")---   , it "000004-012.ring_trust" (testSerialization "000004-012.ring_trust")---   , it "000005-014.public_subkey" (testSerialization "000005-014.public_subkey")---   , it "000006-002.sig" (testSerialization "000006-002.sig")---   , it "000007-012.ring_trust" (testSerialization "000007-012.ring_trust")---   , it "000008-006.public_key" (testSerialization "000008-006.public_key")---   , it "000009-013.user_id" (testSerialization "000009-013.user_id")---   , it "000010-002.sig" (testSerialization "000010-002.sig")---   , it "000011-012.ring_trust" (testSerialization "000011-012.ring_trust")---   , it "000012-014.public_subkey" (testSerialization "000012-014.public_subkey")---   , it "000013-002.sig" (testSerialization "000013-002.sig")---   , it "000014-012.ring_trust" (testSerialization "000014-012.ring_trust")---   , it "000015-006.public_key" (testSerialization "000015-006.public_key")---   , it "000016-013.user_id" (testSerialization "000016-013.user_id")---   , it "000017-002.sig" (testSerialization "000017-002.sig")---   , it "000018-012.ring_trust" (testSerialization "000018-012.ring_trust")---   , it "000019-006.public_key" (testSerialization "000019-006.public_key")---   , it "000020-013.user_id" (testSerialization "000020-013.user_id")---   , it "000021-002.sig" (testSerialization "000021-002.sig")---   , it "000022-012.ring_trust" (testSerialization "000022-012.ring_trust")---   , it "000023-005.secret_key" (testSerialization "000023-005.secret_key")---   , it "000024-013.user_id" (testSerialization "000024-013.user_id")---   , it "000025-002.sig" (testSerialization "000025-002.sig")---   , it "000026-012.ring_trust" (testSerialization "000026-012.ring_trust")---   , it "000027-007.secret_subkey" (testSerialization "000027-007.secret_subkey")---   , it "000028-002.sig" (testSerialization "000028-002.sig")---   , it "000029-012.ring_trust" (testSerialization "000029-012.ring_trust")---   , it "000030-005.secret_key" (testSerialization "000030-005.secret_key")---   , it "000031-013.user_id" (testSerialization "000031-013.user_id")---   , it "000032-002.sig" (testSerialization "000032-002.sig")---   , it "000033-012.ring_trust" (testSerialization "000033-012.ring_trust")---   , it "000034-007.secret_subkey" (testSerialization "000034-007.secret_subkey")---   , it "000035-002.sig" (testSerialization "000035-002.sig")---   , it "000036-012.ring_trust" (testSerialization "000036-012.ring_trust")---   , it "000037-005.secret_key" (testSerialization "000037-005.secret_key")---   , it "000038-013.user_id" (testSerialization "000038-013.user_id")---   , it "000039-002.sig" (testSerialization "000039-002.sig")---   , it "000040-012.ring_trust" (testSerialization "000040-012.ring_trust")---   , it "000041-005.secret_key" (testSerialization "000041-005.secret_key")---   , it "000042-013.user_id" (testSerialization "000042-013.user_id")---   , it "000043-002.sig" (testSerialization "000043-002.sig")---   , it "000044-012.ring_trust" (testSerialization "000044-012.ring_trust")---   , it "pubring.gpg" (testSerialization "pubring.gpg")---   , it "secring.gpg" (testSerialization "secring.gpg")---   ]---- main = hspec specs  main = defaultMain tests