diff --git a/Codec/Encryption/OpenPGP/Compression.hs b/Codec/Encryption/OpenPGP/Compression.hs --- a/Codec/Encryption/OpenPGP/Compression.hs +++ b/Codec/Encryption/OpenPGP/Compression.hs @@ -1,6 +1,6 @@ --- ASCIIArmor.hs: OpenPGP (RFC4880) ASCII armor implementation --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Compression.hs: OpenPGP (RFC4880) compression and decompression +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Compression ( @@ -11,7 +11,7 @@ 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.Serialize () import Codec.Encryption.OpenPGP.Types import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -21,7 +21,7 @@ import Data.Serialize.Put (runPut) decompressPacket :: Packet -> [Packet] -decompressPacket (CompressedData algo bs) = case (runGet get . B.concat . BL.toChunks) (decompressPacket' algo bs) of +decompressPacket (CompressedData algo bs') = case (runGet get . B.concat . BL.toChunks) (decompressPacket' algo bs') of Left _ -> [] Right packs -> unBlock packs where @@ -29,15 +29,17 @@ 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' _ _ = error "Compression algorithm not supported" 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 + 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] + compressPackets' _ _ = error "Compression algorithm not supported" diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -1,3 +1,8 @@ +-- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. +-- (See the LICENSE file). + module Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint @@ -5,7 +10,6 @@ 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) @@ -16,3 +20,4 @@ fingerprint :: PKPayload -> TwentyOctetFingerprint fingerprint (PubV4 ts pka pk) = (TwentyOctetFingerprint . SHA1.hash) (runPut $ putPKPforFingerprinting (PublicKey (PubV4 ts pka pk))) +fingerprint _ = error "non-V4 not implemented" diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -1,6 +1,6 @@ -- Internal.hs: private utility functions --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Internal ( @@ -19,11 +19,11 @@ countBits bs = fromIntegral (B.length bs * 8) - fromIntegral (go (B.head bs) 7) where go :: Word8 -> Int -> Word8 - go n 0 = 7 + go _ 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 +beBSToInteger = sum . 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)) diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -1,9 +1,10 @@ -- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal) --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Serialize ( + putSKAddendum ) where import Control.Applicative ((<$>),(<*>)) @@ -15,13 +16,12 @@ 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 Data.Word (Word8, Word32) import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS) import Codec.Encryption.OpenPGP.Types @@ -83,7 +83,7 @@ getSigSubPacket :: Get SigSubPacket getSigSubPacket = do - l <- getSubPacketLength + l <- fmap fromIntegral getSubPacketLength (crit, pt) <- getSigSubPacketType getSigSubPacket' pt crit l where @@ -166,8 +166,8 @@ hash <- getByteString (l - 3) return $ SignatureTarget crit pka ha hash | pt == 32 = do - spb <- getByteString (l - 1) - return $ EmbeddedSignature crit spb -- FIXME: should be sigpacket + sp <- get :: Get SignaturePayload + return $ EmbeddedSignature crit sp | pt > 99 && pt < 111 = do payload <- getByteString (l - 1) return $ UserDefinedSigSub crit pt payload @@ -194,7 +194,7 @@ put tl put ta putSigSubPacket (RegularExpression crit apdre) = do - putSubPacketLength (2 + B.length apdre) + putSubPacketLength . fromIntegral $ (2 + B.length apdre) putSigSubPacketType crit 6 putByteString apdre putWord8 0 @@ -207,7 +207,7 @@ putSigSubPacketType crit 9 putWord32be et putSigSubPacket (PreferredSymmetricAlgorithms crit ess) = do - putSubPacketLength (1 + length ess) + putSubPacketLength . fromIntegral $ (1 + length ess) putSigSubPacketType crit 11 mapM_ put ess putSigSubPacket (RevocationKey crit rclass algid fp) = do @@ -221,7 +221,7 @@ putSigSubPacketType crit 16 putByteString (unEOKI keyid) -- 8 octets putSigSubPacket (NotationData crit nfs nn nv) = do - putSubPacketLength (9 + B.length nn + B.length nv) + putSubPacketLength . fromIntegral $ (9 + B.length nn + B.length nv) putSigSubPacketType crit 20 putByteString . ffSetToFixedLengthBS 4 $ nfs putWord16be . fromIntegral . B.length $ nn @@ -229,20 +229,20 @@ putByteString nn putByteString nv putSigSubPacket (PreferredHashAlgorithms crit ehs) = do - putSubPacketLength (1 + length ehs) + putSubPacketLength . fromIntegral $ (1 + length ehs) putSigSubPacketType crit 21 mapM_ put ehs putSigSubPacket (PreferredCompressionAlgorithms crit ecs) = do - putSubPacketLength (1 + length ecs) + putSubPacketLength . fromIntegral $ (1 + length ecs) putSigSubPacketType crit 22 mapM_ put ecs putSigSubPacket (KeyServerPreferences crit ksps) = do let kbs = ffSetToBS ksps - putSubPacketLength (1 + B.length kbs) + putSubPacketLength . fromIntegral $ (1 + B.length kbs) putSigSubPacketType crit 23 putByteString kbs putSigSubPacket (PreferredKeyServer crit ks) = do - putSubPacketLength (1 + B.length ks) + putSubPacketLength . fromIntegral $ (1 + B.length ks) putSigSubPacketType crit 24 putByteString ks putSigSubPacket (PrimaryUserId crit primacy) = do @@ -250,48 +250,49 @@ putSigSubPacketType crit 25 put primacy putSigSubPacket (PolicyURL crit url) = do - putSubPacketLength (1 + B.length url) + putSubPacketLength . fromIntegral $ (1 + B.length url) putSigSubPacketType crit 26 putByteString url putSigSubPacket (KeyFlags crit kfs) = do let kbs = ffSetToBS kfs - putSubPacketLength (1 + B.length kbs) + putSubPacketLength . fromIntegral $ (1 + B.length kbs) putSigSubPacketType crit 27 putByteString kbs putSigSubPacket (SignersUserId crit userid) = do - putSubPacketLength (1 + B.length userid) + putSubPacketLength . fromIntegral $ (1 + B.length userid) putSigSubPacketType crit 28 putByteString userid putSigSubPacket (ReasonForRevocation crit rcode rreason) = do - putSubPacketLength (2 + B.length rreason) + putSubPacketLength . fromIntegral $ (2 + B.length rreason) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode putByteString rreason putSigSubPacket (Features crit fs) = do let fbs = ffSetToBS fs - putSubPacketLength (1 + B.length fbs) + putSubPacketLength . fromIntegral $ (1 + B.length fbs) putSigSubPacketType crit 30 putByteString fbs putSigSubPacket (SignatureTarget crit pka ha hash) = do - putSubPacketLength (3 + B.length hash) + putSubPacketLength . fromIntegral $ (3 + B.length hash) putSigSubPacketType crit 31 put pka put ha putByteString hash -putSigSubPacket (EmbeddedSignature crit spb) = do - putSubPacketLength (1 + B.length spb) +putSigSubPacket (EmbeddedSignature crit sp) = do + let spb = runPut (put sp) + putSubPacketLength . fromIntegral $ (1 + B.length spb) putSigSubPacketType crit 32 putByteString spb putSigSubPacket (UserDefinedSigSub crit ptype payload) = do - putSubPacketLength (1 + B.length payload) + putSubPacketLength . fromIntegral $ (1 + B.length payload) putSigSubPacketType crit ptype putByteString payload putSigSubPacket (OtherSigSub crit ptype payload) = do - putSubPacketLength (1 + B.length payload) + putSubPacketLength . fromIntegral $ (1 + B.length payload) putSigSubPacketType crit ptype putByteString payload -getSubPacketLength :: Integral a => Get a +getSubPacketLength :: Get Word32 getSubPacketLength = getSubPacketLength' =<< getWord8 where getSubPacketLength' :: Integral a => Word8 -> Get a @@ -305,7 +306,7 @@ return . fromIntegral $ len | otherwise = fail "Partial body length invalid." -putSubPacketLength :: Integral a => a -> Put +putSubPacketLength :: Word32 -> Put putSubPacketLength l | l < 192 = putWord8 (fromIntegral l) | l < 8384 = putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l - 192) .&. 0xff) @@ -337,12 +338,14 @@ fromS2K (Simple hashalgo) = B.pack [0, fromIntegral . fromFVal $ hashalgo] fromS2K (Salted hashalgo salt) | B.length salt == 8 = B.pack [1, fromIntegral . fromFVal $ hashalgo] `B.append` salt + | otherwise = error "Confusing salt size" fromS2K (IteratedSalted hashalgo salt count) | B.length salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.snoc` (encodeIterationCount count) -fromS2K (OtherS2K t bs) = bs + | otherwise = error "Confusing salt size" +fromS2K (OtherS2K _ bs) = bs -getPacketLength :: Integral a => Get a +getPacketLength :: Get Integer getPacketLength = do firstOctet <- getWord8 getPacketLength' firstOctet @@ -358,7 +361,7 @@ return . fromIntegral $ len | otherwise = fail "Partial body length support missing." --FIXME -putPacketLength :: Integral a => a -> Put +putPacketLength :: Integer -> Put putPacketLength l | l < 192 = putWord8 (fromIntegral l) | l < 8384 = putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l - 192) .&. 0xff) @@ -385,6 +388,8 @@ | otherwise = error "Unknown S2K" putS2K :: S2K -> Put +putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo) +putS2K (Salted hashalgo salt) = error ("confused by salted" ++ show hashalgo ++ " by " ++ show salt) putS2K (IteratedSalted ha salt count) = do putWord8 3 put ha @@ -411,9 +416,10 @@ bs <- getByteString len return (t, bs) 0x40 -> do - len <- getPacketLength + len <- fmap fromIntegral getPacketLength bs <- getByteString len return (tag .&. 0x3f, bs) + _ -> error "This should never happen." getPacket :: Get Packet getPacket = do @@ -443,10 +449,6 @@ pv <- getWord8 symalgo <- getWord8 s2k <- getS2K - let partiallen = case s2k of - Simple _ -> 1 + 3 - Salted _ _ -> 9 + 3 - IteratedSalted _ _ _ -> 10 + 3 remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of @@ -523,7 +525,7 @@ getUserAttrSubPacket :: Get UserAttrSubPacket getUserAttrSubPacket = do - l <- getSubPacketLength + l <- fmap fromIntegral getSubPacketLength t <- getWord8 getUserAttrSubPacket' t l where @@ -533,9 +535,9 @@ ihlen <- getWord16le hver <- getWord8 -- should be 1 iformat <- getWord8 - _ <- getBytes 12 -- should be NULs + nuls <- getBytes 12 -- should be NULs bs <- getByteString (l - 17) - return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs + if hver /= 1 || nuls /= (B.pack (replicate 12 0)) then fail "Corrupt UAt subpacket" else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs | otherwise = do bs <- getByteString (l - 1) return $ OtherUASub t bs @@ -543,7 +545,7 @@ putUserAttrSubPacket :: UserAttrSubPacket -> Put putUserAttrSubPacket ua = do let sp = runPut $ putUserAttrSubPacket' ua - putSubPacketLength . B.length $ sp + putSubPacketLength . fromIntegral . B.length $ sp putByteString sp where putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do @@ -561,7 +563,7 @@ putPacket (PKESK pv eokeyid pkalgo mpis) = do putWord8 (0xc0 .|. 1) let bsk = runPut $ mapM_ put mpis - putPacketLength $ 10 + (B.length bsk) + putPacketLength . fromIntegral $ 10 + (B.length bsk) putWord8 pv -- must be 3 putByteString (unEOKI eokeyid) -- must be 8 octets putWord8 $ fromIntegral . fromFVal $ pkalgo @@ -569,13 +571,13 @@ putPacket (Signature sp) = do putWord8 (0xc0 .|. 2) let bs = runPut $ put sp - putPacketLength . B.length $ bs + putPacketLength . fromIntegral . B.length $ bs putByteString bs putPacket (SKESK pv symalgo s2k mpis) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k let bsk = runPut $ mapM_ put mpis - putPacketLength $ 2 + (B.length bs2k) + (B.length bsk) + putPacketLength . fromIntegral $ 2 + (B.length bs2k) + (B.length bsk) putWord8 pv -- should be 4 putWord8 $ fromIntegral . fromFVal $ symalgo putByteString bs2k @@ -589,37 +591,37 @@ putWord8 $ fromIntegral . fromFVal $ pka putByteString (unEOKI skeyid) putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean? - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SecretKey pkp ska) = do putWord8 (0xc0 .|. 5) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (PublicKey pkp) = do putWord8 (0xc0 .|. 6) let bs = runPut $ putPKPayload pkp - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SecretSubkey pkp ska) = do putWord8 (0xc0 .|. 7) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (CompressedData ca cdata) = do putWord8 (0xc0 .|. 8) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ ca putByteString cdata - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SymEncData b) = do putWord8 (0xc0 .|. 9) - putPacketLength $ B.length b + putPacketLength . fromIntegral $ B.length b putByteString b putPacket (Marker b) = do putWord8 (0xc0 .|. 10) - putPacketLength $ B.length b + putPacketLength . fromIntegral $ B.length b putByteString b putPacket (LiteralData dt fn ts b) = do putWord8 (0xc0 .|. 11) @@ -629,39 +631,39 @@ putByteString fn putWord32be ts putByteString b - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (Trust b) = do putWord8 (0xc0 .|. 12) - putPacketLength . B.length $ b + putPacketLength . fromIntegral . B.length $ b putByteString b putPacket (UserId u) = do putWord8 (0xc0 .|. 13) let bs = BC8.pack u - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (PublicSubkey pkp) = do putWord8 (0xc0 .|. 14) let bs = runPut $ putPKPayload pkp - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (UserAttribute us) = do putWord8 (0xc0 .|. 17) let bs = runPut $ mapM_ put us - putPacketLength $ B.length bs + putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SymEncIntegrityProtectedData pv b) = do putWord8 (0xc0 .|. 18) - putPacketLength $ (B.length b) + 1 + putPacketLength . fromIntegral $ (B.length b) + 1 putWord8 pv -- should be 1 putByteString b putPacket (ModificationDetectionCode hash) = do putWord8 (0xc0 .|. 19) - putPacketLength . B.length $ hash + putPacketLength . fromIntegral . B.length $ hash putByteString hash putPacket (OtherPacket t payload) = do putWord8 (0xc0 .|. t) -- FIXME: restrict t - putPacketLength . B.length $ payload + putPacketLength . fromIntegral . B.length $ payload putByteString payload getMPI :: Get MPI @@ -685,6 +687,7 @@ MPI g <- get MPI y <- get return $ ElGamalPubKey [p,g,y] +getPubkey t = fail ("Unsupported pubkey type " ++ show t) pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey k) = [MPI (R.public_n k), MPI (R.public_e k)] @@ -698,7 +701,7 @@ getSecretKey RSA = do MPI d <- get MPI p <- get MPI q <- get - MPI u <- get + MPI _ <- get let n = p * q let dP = 0 let dQ = 0 @@ -712,22 +715,22 @@ getSecretKey Elgamal = do MPI x <- get return $ ElGamalPrivateKey [x] -indefiniteMPIs :: ByteString -> [MPI] -indefiniteMPIs bs = do - case runGet (many getMPI) bs of - Left e -> error e - Right mpis -> mpis +-- indefiniteMPIs :: ByteString -> [MPI] +-- indefiniteMPIs bs = do +-- case runGet (many getMPI) bs of +-- Left e -> error e +-- Right mpis -> mpis putMPI :: MPI -> Put putMPI (MPI i) = do let bs = integerToBEBS i putWord16be . countBits $ bs putByteString bs -getPackets :: Get (Block Packet) -getPackets = Block `fmap` many getPacket +-- getPackets :: Get (Block Packet) +-- getPackets = Block `fmap` many getPacket -putPackets :: Block Packet -> Put -putPackets = mapM_ putPacket . unBlock +-- putPackets :: Block Packet -> Put +-- putPackets = mapM_ putPacket . unBlock getPKPayload :: Get PKPayload getPKPayload = do @@ -791,6 +794,7 @@ put s2k putByteString iv putByteString encryptedblock +putSKAddendum _ = fail "Type not supported" symEncBlockSize :: SymmetricAlgorithm -> Int symEncBlockSize (Plaintext) = 0 @@ -802,7 +806,7 @@ symEncBlockSize (AES192) = 16 symEncBlockSize (AES256) = 16 symEncBlockSize (Twofish) = 16 -symEncBlockSize x = 8 -- FIXME +symEncBlockSize _ = 8 -- FIXME decodeIterationCount :: Word8 -> Int decodeIterationCount c = (16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6) @@ -1064,14 +1068,14 @@ encodeIterationCount 60817408 = 253 encodeIterationCount 62914560 = 254 encodeIterationCount 65011712 = 255 -encodeIterationCount n = error "invalid iteration count" +encodeIterationCount n = error ("invalid iteration count" ++ show n) getSignaturePayload :: Get SignaturePayload getSignaturePayload = do pv <- getWord8 case pv of 3 -> do - hashlen <- getWord8 -- must be 5 + hashlen <- getWord8 -- FIXME: must be 5 st <- getWord8 ctime <- getWord32be eok <- getByteString 8 @@ -1103,11 +1107,12 @@ 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 + _ -> do remainder <- remaining bs <- getByteString remainder return $ SigVOther pv bs +putSignaturePayload :: SignaturePayload -> Put putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do putWord8 3 put st @@ -1130,6 +1135,7 @@ putByteString ub putWord16be left16 mapM_ put mpis +putSignaturePayload _ = fail "Signature version not supported" -- Stolen from Axman6 many :: Get a -> Get [a] diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -1,12 +1,13 @@ -- 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. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.SerializeForSigs ( putPKPforFingerprinting , putPartialSigforSigning , putSigTrailer + , putUforSigning , putUIDforSigning , putUAtforSigning , putKeyforSigning @@ -14,36 +15,24 @@ -- , 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 Data.Serialize (Serialize, put) +import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, runPut) -import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS) -import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.Serialize (putSKAddendum) import Codec.Encryption.OpenPGP.Types putPKPforFingerprinting :: Packet -> Put -- FIXME putPKPforFingerprinting (PublicKey pkp) = do - putWord8 (0x99) + putWord8 0x99 let bs = runPut $ put pkp putWord16be . fromIntegral $ B.length bs putByteString bs +putPKPforFingerprinting _ = fail "This should never happen" putPartialSigforSigning :: Packet -> Put -putPartialSigforSigning (Signature (SigV4 st pka ha hashed unhashed left16 mpis)) = do +putPartialSigforSigning (Signature (SigV4 st pka ha hashed _ _ _)) = do putWord8 4 put st put pka @@ -51,27 +40,36 @@ let hb = runPut $ mapM_ put hashed putWord16be . fromIntegral . B.length $ hb putByteString hb +putPartialSigforSigning _ = fail "This should never happen" putSigTrailer :: Packet -> Put putSigTrailer (Signature (SigV4 _ _ _ hs _ _ _)) = do putWord8 0x04 putWord8 0xff - putWord32be . fromIntegral . (+6) . B.length $ (runPut $ mapM_ put hs) + putWord32be . fromIntegral . (+6) . B.length $ runPut $ mapM_ put hs -- this +6 seems like a bug in RFC4880 +putSigTrailer _ = fail "This should never happen" +putUforSigning :: Packet -> Put +putUforSigning u@(UserId _) = putUIDforSigning u +putUforSigning u@(UserAttribute _) = putUAtforSigning u +putUforSigning _ = fail "This should never happen" + putUIDforSigning :: Packet -> Put putUIDforSigning (UserId u) = do putWord8 0xB4 let bs = BC8.pack u putWord32be . fromIntegral . B.length $ bs putByteString bs +putUIDforSigning _ = fail "This should never happen" putUAtforSigning :: Packet -> Put putUAtforSigning (UserAttribute us) = do putWord8 0xD1 - let bs = B.empty -- FIXME: what gets hashed? + let bs = runPut (mapM_ put us) putWord32be . fromIntegral . B.length $ bs putByteString bs +putUAtforSigning _ = fail "This should never happen" putSigforSigning :: Packet -> Put putSigforSigning (Signature (SigV4 st pka ha hashed _ left16 mpis)) = do @@ -79,17 +77,18 @@ let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis) putWord32be . fromIntegral . B.length $ bs putByteString bs +putSigforSigning _ = fail "Non-V4 not implemented." 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 (PublicKey pkp) = putKeyForSigning' pkp +putKeyforSigning (PublicSubkey pkp) = putKeyForSigning' pkp +putKeyforSigning (SecretKey pkp _) = putKeyForSigning' pkp +putKeyforSigning (SecretSubkey pkp _) = putKeyForSigning' pkp +putKeyforSigning _ = fail "This should never happen" -putKeyForSigning' :: PKPayload -> Maybe SKAddendum -> Put -putKeyForSigning' pkp mska = do +putKeyForSigning' :: PKPayload -> Put +putKeyForSigning' pkp = do putWord8 0x99 let bs = runPut $ put pkp - -- FIXME: add ska - putWord32be . fromIntegral . B.length $ bs + putWord16be . fromIntegral . B.length $ bs putByteString bs diff --git a/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -1,6 +1,6 @@ -- Types.hs: OpenPGP (RFC4880) data types --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Types ( @@ -24,7 +24,7 @@ , SKey(..) , EightOctetKeyId(..) , TwentyOctetFingerprint(..) - , KRK(..) + , TK(..) , FutureFlag , FutureVal , Keyring @@ -61,7 +61,6 @@ type NotationName = ByteString type NotationValue = ByteString type UserId = ByteString -type SignaturePacketBody = ByteString type SignatureHash = ByteString type PacketVersion = Word8 type Salt = ByteString @@ -99,6 +98,8 @@ fromFVal TripleDES = 2 fromFVal CAST5 = 3 fromFVal Blowfish = 4 + fromFVal ReservedSAFER = 5 + fromFVal ReservedDES = 6 fromFVal AES128 = 7 fromFVal AES192 = 8 fromFVal AES256 = 9 @@ -109,6 +110,8 @@ toFVal 2 = TripleDES toFVal 3 = CAST5 toFVal 4 = Blowfish + toFVal 5 = ReservedSAFER + toFVal 6 = ReservedDES toFVal 7 = AES128 toFVal 8 = AES192 toFVal 9 = AES256 @@ -154,7 +157,7 @@ | ReasonForRevocation Bool RevocationCode RevocationReason | Features Bool (Set FeatureFlag) | SignatureTarget Bool PubKeyAlgorithm HashAlgorithm SignatureHash - | EmbeddedSignature Bool SignaturePacketBody + | EmbeddedSignature Bool SignaturePayload | UserDefinedSigSub Bool Word8 ByteString | OtherSigSub Bool Word8 ByteString deriving (Show, Eq) -- FIXME @@ -263,8 +266,8 @@ toFVal o = OtherPKA o class (Eq a, Ord a) => FutureFlag a where - fromFFlag :: Integral b => a -> b - toFFlag :: Integral b => b-> a + fromFFlag :: a -> Int + toFFlag :: Int -> a data KSPFlag = NoModify | KSPOther Int @@ -550,7 +553,7 @@ show = w8sToHex . B.unpack . unEOKI instance Read EightOctetKeyId where - readsPrec 0 = map ((EightOctetKeyId . B.pack *** concat) . unzip) . splitEvery 8 . hexToW8s + readsPrec _ = map ((EightOctetKeyId . B.pack *** concat) . unzip) . splitEvery 8 . hexToW8s newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString} deriving (Eq) @@ -558,13 +561,26 @@ instance Show TwentyOctetFingerprint where show = take 50 . concatMap (++" ") . concatMap (++[""]) . splitEvery 5 . splitEvery 4 . w8sToHex . B.unpack . unTOF +instance Read TwentyOctetFingerprint where + readsPrec _ = map ((TwentyOctetFingerprint . B.pack *** concat) . unzip) . splitEvery 20 . hexToW8s . filter (/= ' ') + 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 KRK = TPK PKPayload [SignaturePayload] [(String, [SignaturePayload])] [([UserAttrSubPacket], [SignaturePayload])] [(PKPayload, SignaturePayload, Maybe SignaturePayload)] | TSK Packet [SignaturePayload] [(String, [SignaturePayload])] [([UserAttrSubPacket], [SignaturePayload])] [(Packet, SignaturePayload, Maybe SignaturePayload)] | NTSubkey Packet | NTSecretSubkey Packet | NoKRK +data TK = TK { + tkPKP :: PKPayload + , tkmSKA :: (Maybe SKAddendum) + , tkRevs :: [SignaturePayload] + , tkUIDs :: [(String, [SignaturePayload])] + , tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] + , tkSubs :: [(Packet, SignaturePayload, Maybe SignaturePayload)] + } deriving (Eq, Show) -type Keyring = Map EightOctetKeyId KRK +instance Ord TK where + compare a b = show a `compare` show b -- FIXME: this is ridiculous + +type Keyring = Map EightOctetKeyId (Set TK) diff --git a/Data/Conduit/OpenPGP/Compression.hs b/Data/Conduit/OpenPGP/Compression.hs --- a/Data/Conduit/OpenPGP/Compression.hs +++ b/Data/Conduit/OpenPGP/Compression.hs @@ -1,6 +1,6 @@ -- Compression.hs: OpenPGP (RFC4880) compression conduits --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Data.Conduit.OpenPGP.Compression ( @@ -17,7 +17,7 @@ conduitCompress algo = conduitState [] push (close algo) where push state input = return $ StateProducing (input : state) [] - close algo state = return $ [compressPackets algo state] + close a state = return [compressPackets a state] conduitDecompress :: MonadThrow m => Conduit Packet m Packet conduitDecompress = CL.concatMap decompressPacket diff --git a/Data/Conduit/OpenPGP/Internal.hs b/Data/Conduit/OpenPGP/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Internal.hs @@ -0,0 +1,105 @@ +-- Internal.hs: OpenPGP (RFC4880) private routines for conduit stuff +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. +-- (See the LICENSE file). + +module Data.Conduit.OpenPGP.Internal ( + PacketStreamContext(..) + , payloadForSig + , asn1Prefix + , hash + , issuer +) where + +import qualified Crypto.Hash.MD5 as MD5 +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.Lazy as BL +import Data.List (find) +import Data.Serialize.Put (runPut) + +import Codec.Encryption.OpenPGP.SerializeForSigs (putKeyforSigning, putUforSigning) +import Codec.Encryption.OpenPGP.Types + +data PacketStreamContext = PacketStreamContext { lastLD :: Packet + , lastUIDorUAt :: Packet + , lastSig :: Packet + , lastPrimaryKey :: Packet + , lastSubkey :: Packet + } + +payloadForSig :: SigType -> PacketStreamContext -> ByteString +payloadForSig BinarySig state = (\(LiteralData _ _ _ bs) -> bs) (lastLD state) +payloadForSig CanonicalTextSig state = payloadForSig BinarySig state +payloadForSig StandaloneSig _ = B.empty +payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) +payloadForSig PersonaCert state = payloadForSig GenericCert state +payloadForSig CasualCert state = payloadForSig GenericCert state +payloadForSig PositiveCert state = payloadForSig GenericCert state +payloadForSig SubkeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well +payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) +payloadForSig SignatureDirectlyOnAKey state = runPut (putKeyforSigning (lastPrimaryKey state)) +payloadForSig KeyRevocationSig state = payloadForSig SignatureDirectlyOnAKey state +payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) +payloadForSig CertRevocationSig state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures +payloadForSig st _ = error ("I dunno how to " ++ show st) + +kandUPayload :: Packet -> Packet -> ByteString +kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) + +kandKPayload :: Packet -> Packet -> ByteString +kandKPayload k1 k2 = runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2]) + +issuer :: Packet -> Maybe EightOctetKeyId +issuer (Signature (SigV4 _ _ _ _ usubs _ _)) = fmap (\(Issuer _ i) -> i) (find isIssuer usubs) + where + isIssuer (Issuer _ _) = True + isIssuer _ = False +issuer _ = Nothing + +hash :: HashAlgorithm -> ByteString -> ByteString +hash SHA1 = SHA1.hash +hash RIPEMD160 = RIPEMD160.hash +hash SHA256 = SHA256.hash +hash SHA384 = SHA384.hash +hash SHA512 = SHA512.hash +hash SHA224 = SHA224.hash +hash DeprecatedMD5 = MD5.hash +hash _ = id -- FIXME + +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 _ -> error "encodeASN1 failure" + Right l -> B.concat . BL.toChunks $ getPrefix l + where + getPrefix = BL.reverse . BL.dropWhile (==0) . BL.drop 1 . BL.reverse + bitLength DeprecatedMD5 = 128 + bitLength SHA1 = 160 + bitLength RIPEMD160 = 160 + bitLength SHA256 = 256 + bitLength SHA384 = 384 + bitLength SHA512 = 512 + bitLength SHA224 = 224 + bitLength _ = 0 + 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] + hashOid _ = DER.OID [] diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -1,18 +1,19 @@ -- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Data.Conduit.OpenPGP.Keyring ( - conduitToKRKs + conduitToTKs + , conduitToTKsDropping , sinkKeyringMap ) where import qualified Data.ByteString as B import Data.Conduit -import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Set as Set import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) import Codec.Encryption.OpenPGP.Types @@ -20,66 +21,77 @@ data Phase = MainKey | Revs | Uids | UAts | Subs deriving (Eq, Ord, Show) -conduitToKRKs :: MonadResource m => Conduit Packet m KRK -conduitToKRKs = conduitState (MainKey, NoKRK) push close +conduitToTKs :: MonadResource m => Conduit Packet m TK +conduitToTKs = conduitToTKs' True + +conduitToTKsDropping :: MonadResource m => Conduit Packet m TK +conduitToTKsDropping = conduitToTKs' False + +conduitToTKs' :: MonadResource m => Bool -> Conduit Packet m TK +conduitToTKs' intolerant = conduitState (MainKey, Nothing) 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)]) [NTSubkey (PublicSubkey p)] - ((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)]) [NTSubkey (PublicSubkey p)] - ((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)])) [NTSubkey (PublicSubkey p)] - ((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)]) [NTSecretSubkey (SecretSubkey p s)] - ((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)]) [NTSecretSubkey (SecretSubkey p s)] - ((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)])) [NTSecretSubkey (SecretSubkey p s)] - ((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] + ((MainKey, _), PublicKey pkp) -> return $ StateProducing (Revs, Just (TK pkp Nothing [] [] [] [])) [] + ((MainKey, _), SecretKey pkp ska) -> return $ StateProducing (Revs, Just (TK pkp (Just ska) [] [] [] [])) [] + ((Revs, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (Revs, Just (TK pkp Nothing (revs ++ [s]) uids uats subs)) [] + ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)) [] + ((Uids, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (addUidSig s uids) uats subs)) [] + ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] + ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)) [] + ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkey p, SigVOther 0 B.empty, Nothing)])) [] + ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (addUAtSig s uats) subs)) [] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)) [] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] + ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkey p, SigVOther 0 B.empty, Nothing)])) [] + ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] + ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkey p) -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkey p, SigVOther 0 B.empty, Nothing)]))) [] + ((Subs, Just (TK pkp Nothing revs uids uats subs)), Signature s) -> case sType s of + SubkeyBindingSig -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setBSig s subs))) [] + SubkeyRevocationSig -> return $ StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setRSig s subs))) [] + _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input) + ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKey p) -> return $ StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] + ((Revs, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (Revs, Just (TK pkp mska (revs ++ [s]) uids uats subs)) [] + ((Revs, Just (TK pkp mska revs _ uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs [(u, [])] uats subs)) [] + ((Uids, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (Uids, Just (TK pkp mska revs (addUidSig s uids) uats subs)) [] + ((Uids, Just (TK pkp mska revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] + ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids [(u, [])] subs)) [] + ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) [] + ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] + ((UAts, Just (TK pkp mska revs uids uats subs)), Signature s) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (addUAtSig s uats) subs)) [] + ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttribute u) -> return $ StateProducing (UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)) [] + ((UAts, Just (TK pkp mska revs uids uats subs)), UserId u) -> return $ StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] + ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)])) [] + ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] + ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkey p s) -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkey p s, SigVOther 0 B.empty, Nothing)]))) [] + ((Subs, Just (TK pkp mska revs uids uats subs)), Signature s) -> case sType s of + SubkeyBindingSig -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (setBSig s subs))) [] + SubkeyRevocationSig -> return $ StateProducing (Subs, Just (TK pkp mska revs uids uats (setRSig s subs))) [] + _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input) + ((Subs, Just (TK pkp mska revs uids uats subs)), SecretKey p s) -> return $ StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] ((_,_), Trust _) -> return $ StateProducing state [] - otherwise -> error $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input - close (_, tk) = return [tk] + _ -> return (dropOrError intolerant state $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input) + close (_, Nothing) = return [] + close (_, Just 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)] + setBSig s subs = init subs ++ [(\(p, _, r) -> (p, s, r)) (last subs)] + setRSig s subs = init subs ++ [(\(p, b, _) -> (p, b, Just s)) (last subs)] sType (SigV3 st _ _ _ _ _ _) = st sType (SigV4 st _ _ _ _ _ _) = st - + sType _ = error "This should never happen." + dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ConduitStateResult (Phase, Maybe TK) Packet TK + dropOrError True _ e = error e + dropOrError False s _ = StateProducing s [] -sinkKeyringMap :: MonadResource m => Sink KRK m (Map EightOctetKeyId KRK) +sinkKeyringMap :: MonadResource m => Sink TK m Keyring sinkKeyringMap = sinkState Map.empty push close where - push :: MonadResource m => Map EightOctetKeyId KRK -> KRK -> m (SinkStateResult (Map EightOctetKeyId KRK) KRK (Map EightOctetKeyId KRK)) - 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 - eok (NTSubkey (PublicSubkey pkp)) = eightOctetKeyID pkp - eok (NTSecretSubkey (SecretSubkey p s)) = eightOctetKeyID p + push :: MonadResource m => Keyring -> TK -> m (SinkStateResult Keyring TK Keyring) + push state input = return . StateProcessing $ foldl (\m x -> Map.insert x (newset x input m) m) state (eoks input) + close = return + eoks (TK pkp _ _ _ _ subs) = (eightOctetKeyID pkp):map (eightOctetKeyID . pl . \(x,_,_) -> x) subs + pl (PublicSubkey pkp) = pkp + pl (SecretSubkey pkp _) = pkp + newset eok i s = Set.insert i (oldset eok s) + oldset = Map.findWithDefault Set.empty diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -1,6 +1,6 @@ -- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. -- (See the LICENSE file). module Data.Conduit.OpenPGP.Verify ( @@ -10,149 +10,76 @@ 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 Data.Either (lefts, rights) import qualified Data.Map as Map +import qualified Data.Set as Set 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.SerializeForSigs (putPartialSigforSigning, putSigTrailer) import Codec.Encryption.OpenPGP.Types - -data StreamState = StreamState { lastLD :: Packet - , lastUIDorUAt :: Packet - , lastSig :: Packet - , lastPrimaryKey :: Packet - , lastSubkey :: Packet - } +import Data.Conduit.OpenPGP.Internal (PacketStreamContext(..), payloadForSig, asn1Prefix, hash, issuer) -conduitVerify :: MonadResource 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 +conduitVerify :: MonadResource m => Keyring -> Conduit Packet m (Either String PKPayload) +conduitVerify kr = conduitState (PacketStreamContext (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 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 [] + push state sig@(Signature (SigV4 {})) = return $ StateProducing state { lastSig = sig } [verifySig kr sig state] + push state (OnePassSignature _ _ _ _ _ False) = return $ StateProducing state [] + push state _ = return $ StateProducing state [] + close _ = 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 +verifySig :: Keyring -> Packet -> PacketStreamContext -> Either String PKPayload -- FIXME: this should be more informative +verifySig kr sig@(Signature (SigV4 st _ _ _ _ _ _)) state = verify kr sig (payloadForSig st state) +verifySig _ _ _ = Left "This should never happen." -go kr sig payload = case issuer sig of - Nothing -> Left "pubkey not found" - Just i -> verify' (Map.lookup i kr) sig payload +verify :: Keyring -> Packet -> ByteString -> Either String PKPayload +verify kr sig payload = do + i <- maybe (Left "issuer not found") Right (issuer sig) + tpkset <- maybe (Left "pubkey not found") Right (Map.lookup i kr) + let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> tkPKP x:map subPKP (tkSubs x)) (Set.toAscList tpkset)) + let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps + case rights results of + [] -> Left (concatMap (++"/") (lefts results)) + [r] -> Right r -- FIXME: this should also check expiration time and flags of the signing key + _ -> Left "multiple successes; unexpected condition" 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 + subPKP (pack, _, _) = subPKP' pack + subPKP' (PublicSubkey p) = p + subPKP' (SecretSubkey p _) = p + verify' (Signature s) (pub@(PubV4 _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl + verify' _ _ _ _ = error "This should never happen." + verify'' (DSA,mpis) ha pub (DSAPubKey pkey) bs = verify''' (dsaVerify mpis ha pkey bs) pub + verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis ha pkey bs) pub + verify'' _ _ _ _ _ = Left "unimplemented key type" + verify''' f pub = case f of + Left _ -> Left "invalid signature" + Right False -> Left "verification failed" + Right True -> Right pub + dsaVerify mpis ha pkey bs = DSA.verify (dsaMPIsToSig mpis) (dsaTruncate pkey . hash ha) pkey bs + rsaVerify mpis ha pkey bs = RSA.verify (hash ha) (asn1Prefix ha) pkey bs (rsaMPItoSig mpis) 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 + rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis)) + finalPayload s pl = B.concat [pl, sigbit s, trailer s] + sigbit s = runPut $ putPartialSigforSigning s + hashalgo :: Packet -> HashAlgorithm hashalgo (Signature (SigV4 _ _ ha _ _ _ _)) = ha - trailer sig@(Signature (SigV4 _ _ _ hs _ _ _)) = runPut $ putSigTrailer sig + hashalgo _ = error "This should never happen." + trailer :: Packet -> ByteString + trailer s@(Signature (SigV4 {})) = runPut $ putSigTrailer s + trailer _ = B.empty 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] + dsaQLen pk = (\(_,_,z) -> countBits (integerToBEBS z)) (DSA.public_params pk) + pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis) + pkaAndMPIs _ = error "This should never happen." diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,19 +1,13 @@ -Copyright Ⓒ 2012 Clint Adams - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies -of the Software, and to permit persons to whom the Software is furnished to do -so, subject to the following conditions: +Copyright © 2012 Clint Adams -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +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", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,9 +1,9 @@ Name: hOpenPGP -Version: 0.3.1 +Version: 0.4 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ -License: MIT +License: OtherLicense License-file: LICENSE Author: Clint Adams Maintainer: Clint Adams @@ -111,6 +111,7 @@ , Data.Conduit.OpenPGP.Verify Other-Modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.SerializeForSigs + , Data.Conduit.OpenPGP.Internal Build-depends: asn1-data , attoparsec , base > 4 && < 5 diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -1,31 +1,31 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Framework (defaultMain, testGroup) +-- suite.hs: hOpenPGP test suite +-- Copyright © 2012 Clint Adams +-- This software is released under the terms of the ISC license. +-- (See the LICENSE file). + +import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit -import Test.HUnit +import Test.HUnit (Assertion, assertFailure, assertEqual) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Compression (decompressPacket, compressPackets) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Types import Data.Conduit.Cereal (conduitGet) -import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress) -import Data.Conduit.OpenPGP.Keyring (conduitToKRKs, sinkKeyringMap) +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap) import Data.Conduit.OpenPGP.Verify (conduitVerify) -import Control.Monad.Exception (runExceptionT, ExceptionT, throw) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Resource (release, allocate, register, resourceMask) -import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC8 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 @@ -50,7 +50,7 @@ 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 + Left _ -> 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 @@ -71,21 +71,24 @@ testKeyIDandFingerprint fp kf = do bs <- B.readFile $ "tests/data/" ++ fp case runGet (get :: Get Packet) bs of - Left err -> assertFailure $ "Decoding of " ++ fp ++ " broke." + Left _ -> assertFailure $ "Decoding of " ++ fp ++ " broke." Right (PublicKey pkp) -> assertEqual ("for " ++ fp) kf (show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) + _ -> assertFailure "Expected public key, got something else." testKeyringLookup :: FilePath -> String -> Bool -> Assertion testKeyringLookup fp eok expected = do - kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fp) DC.$= conduitGet get DC.$= conduitToKRKs DC.$$ sinkKeyringMap + 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.$= conduitToKRKs DC.$$ sinkKeyringMap +testVerifyMessage :: FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion +testVerifyMessage keyring message issuers = 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 + let verification' = map (fmap fingerprint) verification + assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification' +tests :: [Test] tests = [ testGroup "Serialization group" [ testCase "000001-006.public_key" (testSerialization "000001-006.public_key") @@ -174,6 +177,7 @@ , 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") + , testCase "simple.seckey" (testSerialization "simple.seckey") ], testGroup "Keyring group" [ testCase "pubring 7732CF988A63EA86" (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True) @@ -185,13 +189,28 @@ -- 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") + testCase "uncompressed-ops-dsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa.gpg" ([fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"])) + , testCase "uncompressed-ops-dsa-sha384" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa-sha384.txt.gpg" ([fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"])) + , testCase "uncompressed-ops-rsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-rsa.gpg" ([fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"])) + , testCase "compressedsig" (testVerifyMessage "pubring.gpg" "compressedsig.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "compressedsig-zlib" (testVerifyMessage "pubring.gpg" "compressedsig-zlib.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "compressedsig-bzip2" (testVerifyMessage "pubring.gpg" "compressedsig-bzip2.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + ], + testGroup "Certificate verification group" [ + testCase "userid" (testVerifyMessage "pubring.gpg" "minimized.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "subkey" (testVerifyMessage "pubring.gpg" "subkey.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "primary key binding" (testVerifyMessage "signing-subkey.gpg" "primary-binding.gpg" ([fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"])) + , testCase "attribute" (testVerifyMessage "pubring.gpg" "uat.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "primary key revocation" (testVerifyMessage "pubring.gpg" "prikey-rev.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "subkey revocation" (testVerifyMessage "pubring.gpg" "subkey-rev.gpg" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + , testCase "6F87040E" (testVerifyMessage "pubring.gpg" "6F87040E.pubkey" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"])) + , testCase "6F87040E-cr" (testVerifyMessage "pubring.gpg" "6F87040E-cr.pubkey" ([fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"])) + , testCase "simple RSA secret key" (testVerifyMessage "pubring.gpg" "simple.seckey" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) ] ] +fp :: String -> TwentyOctetFingerprint +fp = read + +main :: IO () main = defaultMain tests