diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs b/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs --- a/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs +++ b/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs b/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs --- a/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs +++ b/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Compression.hs b/Codec/Encryption/OpenPGP/Compression.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Compression.hs @@ -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] diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -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))) diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -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)) 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 @@ -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] diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -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 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 @@ -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 diff --git a/Data/Conduit/Cereal/Temp.hs b/Data/Conduit/Cereal/Temp.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/Cereal/Temp.hs @@ -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) diff --git a/Data/Conduit/OpenPGP/Compression.hs b/Data/Conduit/OpenPGP/Compression.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Compression.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -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] diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -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 diff --git a/tests/data/compressedsig.gpg b/tests/data/compressedsig.gpg new file mode 100644 Binary files /dev/null and b/tests/data/compressedsig.gpg differ diff --git a/tests/data/uncompressed-ops-dsa.gpg b/tests/data/uncompressed-ops-dsa.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uncompressed-ops-dsa.gpg differ diff --git a/tests/data/uncompressed-ops-rsa.gpg b/tests/data/uncompressed-ops-rsa.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uncompressed-ops-rsa.gpg differ diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -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