diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor.hs b/Codec/Encryption/OpenPGP/ASCIIArmor.hs deleted file mode 100644 --- a/Codec/Encryption/OpenPGP/ASCIIArmor.hs +++ /dev/null @@ -1,13 +0,0 @@ --- 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.ASCIIArmor ( - armor - , decodeArmor - , parseArmor -) where - -import Codec.Encryption.OpenPGP.ASCIIArmor.Encode (armor) -import Codec.Encryption.OpenPGP.ASCIIArmor.Decode (decodeArmor, parseArmor) diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs b/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs deleted file mode 100644 --- a/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- ASCIIArmor/Decode.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.ASCIIArmor.Decode ( - parseArmor - , decodeArmor -) where - -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(..)) -import Data.Attoparsec.ByteString.Char8 (isDigit_w8) -import Data.Bits (shiftL) -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 (get) -import Data.Serialize.Get (Get, runGet, getWord8) -import Data.Serialize.Put (runPut, putWord32be) -import Data.String (IsString, fromString) -import Data.Word (Word32) - -decodeArmor :: (Integral a, Read a, Show a, IsString e) => ByteString -> Either e (Armor a) -decodeArmor bs = case parse parseArmor bs of - Fail t c e -> Left (fromString e) - Partial _ -> Left (fromString "what") - Done _ r -> Right r - -parseArmor :: (Integral a, Read a, Show a) => Parser (Armor a) -parseArmor = do - atype <- beginLine "begin line" - headers <- armorHeaders "headers" - blankishLine "blank line" - payload <- base64Data "base64 data" - endLine atype "end line" - case runGet get payload of - Left err -> fail err - Right packets -> return $ Armor atype headers (unBlock packets) - -beginLine :: (Integral a, Read a, Show a) => Parser (ArmorType a) -beginLine = do - string "-----BEGIN PGP " - atype <- message <|> pubkey <|> privkey<|> parts <|> signature - string "-----" - many (satisfy (inClass " \t")) - lineEnding - return atype - where - message = string "MESSAGE" >> return ArmorMessage - pubkey = string "PUBLIC KEY BLOCK" >> return ArmorPublicKeyBlock - privkey = string "PRIVATE KEY BLOCK" >> return ArmorPrivateKeyBlock - signature = string "SIGNATURE" >> return ArmorSignature - parts = do - string "MESSAGE, PART " - firstnum <- read . BC8.unpack . B.pack <$> many1 (satisfy isDigit_w8) - return $ ArmorSplitMessageIndefinite firstnum - -lineEnding :: Parser ByteString -lineEnding = string "\n" <|> string "\r\n" - -armorHeaders :: Parser [ArmorHeader] -armorHeaders = many armorHeader - -armorHeader :: Parser ArmorHeader -armorHeader = do - key <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - string ": " - val <- many1 (satisfy (notInClass "\n\r")) - lineEnding - return (B.pack key, B.pack val) - -blankishLine :: Parser ByteString -blankishLine = many (satisfy (inClass " \t")) >> lineEnding - -endLine :: (Integral a, Read a, Show a) => ArmorType a -> Parser ByteString -endLine atype = do - string $ "-----END PGP " `B.append` aType atype `B.append` "-----" - lineEnding - -aType :: (Integral a, Read a, Show a) => ArmorType a -> ByteString -aType (ArmorMessage) = BC8.pack "MESSAGE" -aType (ArmorPublicKeyBlock) = BC8.pack "PUBLIC KEY BLOCK" -aType (ArmorPrivateKeyBlock) = BC8.pack "PRIVATE KEY BLOCK" -aType (ArmorSplitMessage x y) = BC8.pack $ "MESSAGE, PART " ++ show x ++ "/" ++ show y -aType (ArmorSplitMessageIndefinite x) = BC8.pack $ "MESSAGE, PART " ++ show x -aType (ArmorSignature) = BC8.pack "SIGNATURE" - -base64Data :: Parser ByteString -base64Data = do - ls <- many1 base64Line - cksum <- checksumLine - let payload = B.concat ls - let ourcksum = crc24 payload - case runGet d24 cksum of - Left err -> fail err - Right theircksum -> if theircksum == ourcksum then return payload else fail ("CRC24 mismatch: " ++ show (B.unpack cksum) ++ "/" ++ show theircksum ++ " vs. " ++ show ourcksum) - where - base64Line :: Parser ByteString - base64Line = do - b64 <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) - pad <- many (word8 (fromIntegral . fromEnum $ '=')) - lineEnding - let line = B.pack b64 `B.append` B.pack pad - case Base64.decode line of - Left err -> fail err - Right bs -> return bs - checksumLine :: Parser ByteString - checksumLine = do - word8 (fromIntegral . fromEnum $ '=') - b64 <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) - lineEnding - let line = B.pack b64 - case Base64.decode line of - Left err -> fail err - Right bs -> return bs - - -d24 :: Get Word32 -d24 = do - a <- getWord8 - b <- getWord8 - c <- getWord8 - return $ shiftL (fromIntegral a :: Word32) 16 + shiftL (fromIntegral b :: Word32) 8 + (fromIntegral c :: Word32) diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs b/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs deleted file mode 100644 --- a/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs +++ /dev/null @@ -1,59 +0,0 @@ --- ASCIIArmor/Encode.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.ASCIIArmor.Encode ( - armor -) where - -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) - -armor :: (Integral a, Show a) => Armor a -> ByteString -armor (Armor atype ahs ps) = beginLine atype `B.append` armorHeaders ahs `B.append` blankLine `B.append` armorData (opgpStream ps) `B.append` armorChecksum (opgpStream ps) `B.append` endLine atype - -blankLine :: ByteString -blankLine = BC8.singleton '\n' - -beginLine :: (Integral a, Show a) => ArmorType a -> ByteString -beginLine atype = BC8.pack "-----BEGIN PGP " `B.append` aType atype `B.append` BC8.pack "-----\n" - -endLine :: (Integral a, Show a) => ArmorType a -> ByteString -endLine atype = BC8.pack "-----END PGP " `B.append` aType atype `B.append` BC8.pack "-----\n" - -aType :: (Integral a, Show a) => ArmorType a -> ByteString -aType (ArmorMessage) = BC8.pack "MESSAGE" -aType (ArmorPublicKeyBlock) = BC8.pack "PUBLIC KEY BLOCK" -aType (ArmorPrivateKeyBlock) = BC8.pack "PRIVATE KEY BLOCK" -aType (ArmorSplitMessage x y) = BC8.pack $ "MESSAGE, PART " ++ show x ++ "/" ++ show y -aType (ArmorSplitMessageIndefinite x) = BC8.pack $ "MESSAGE, PART " ++ show x -aType (ArmorSignature) = BC8.pack "SIGNATURE" - -armorHeaders :: [ArmorHeader] -> ByteString -armorHeaders ahs = BC8.unlines . map armorHeader $ ahs - where - armorHeader :: ArmorHeader -> ByteString - armorHeader (k, v) = k `B.append` BC8.pack ": " `B.append` v - -opgpStream :: [Packet] -> ByteString -opgpStream = runPut . put . Block - -armorData :: ByteString -> ByteString -armorData = BC8.unlines . wrap76 . Base64.encode - -wrap76 :: ByteString -> [ByteString] -wrap76 bs - | B.null bs = [] - | otherwise = B.take 76 bs : wrap76 (B.drop 76 bs) - -armorChecksum :: ByteString -> ByteString -armorChecksum = BC8.cons '=' . armorData . B.tail . runPut . putWord32be . crc24 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 @@ -7,7 +7,7 @@ ) where import Control.Applicative ((<$>),(<*>)) -import Control.Monad (replicateM, mplus, when) +import Control.Monad (replicateM, mplus) import qualified Crypto.Cipher.RSA as R import qualified Crypto.Cipher.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR) @@ -428,8 +428,11 @@ pv <- getWord8 eokeyid <- getByteString 8 pkalgo <- getWord8 - sk <- getByteString (len - 10) - return $ PKESK pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk + remainder <- remaining + mpib <- getBytes remainder + case runGet (many getMPI) mpib of + Left e -> error e + Right sk -> return $ PKESK pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk | t == 2 = do remainder <- remaining bs <- getBytes remainder @@ -444,8 +447,11 @@ Simple _ -> 1 + 3 Salted _ _ -> 9 + 3 IteratedSalted _ _ _ -> 10 + 3 - msk <- getMSK len partiallen - return $ SKESK pv (toFVal symalgo) s2k msk + remainder <- remaining + mpib <- getBytes remainder + case runGet (many getMPI) mpib of + Left _ -> return $ SKESK pv (toFVal symalgo) s2k [] + Right mpis -> return $ SKESK pv (toFVal symalgo) s2k mpis | t == 4 = do pv <- getWord8 sigtype <- getWord8 @@ -514,14 +520,6 @@ | otherwise = do payload <- getByteString len return $ OtherPacket t payload - where - getMSK :: Int -> Int -> Get (Maybe SessionKey) - getMSK len partiallen - | len == partiallen = return Nothing - | len > partiallen = do - sk <- getByteString (len - partiallen) - return $ Just sk - | otherwise = error "Overread" getUserAttrSubPacket :: Get UserAttrSubPacket getUserAttrSubPacket = do @@ -560,9 +558,9 @@ putByteString bs putPacket :: Packet -> Put -putPacket (PKESK pv eokeyid pkalgo sk) = do +putPacket (PKESK pv eokeyid pkalgo mpis) = do putWord8 (0xc0 .|. 1) - let bsk = sk + let bsk = runPut $ mapM_ put mpis putPacketLength $ 10 + (B.length bsk) putWord8 pv -- must be 3 putByteString (unEOKI eokeyid) -- must be 8 octets @@ -573,14 +571,15 @@ let bs = runPut $ put sp putPacketLength . B.length $ bs putByteString bs -putPacket (SKESK pv symalgo s2k msk) = do +putPacket (SKESK pv symalgo s2k mpis) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k - putPacketLength $ 2 + (B.length bs2k) + (maybe 0 B.length msk) + let bsk = runPut $ mapM_ put mpis + putPacketLength $ 2 + (B.length bs2k) + (B.length bsk) putWord8 pv -- should be 4 putWord8 $ fromIntegral . fromFVal $ symalgo putByteString bs2k - when (isJust msk) $ putByteString (fromJust msk) + putByteString bsk putPacket (OnePassSignature pv sigtype ha pka skeyid nested) = do putWord8 (0xc0 .|. 4) let bs = runPut $ do @@ -806,10 +805,266 @@ symEncBlockSize x = 8 -- FIXME decodeIterationCount :: Word8 -> Int -decodeIterationCount c = fromIntegral $ (16 + (c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6) +decodeIterationCount c = (16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6) -encodeIterationCount :: Int -> Word8 -encodeIterationCount c = fromIntegral c -- FIXME +encodeIterationCount :: Int -> Word8 -- should this really be a lookup table? +encodeIterationCount 1024 = 0 +encodeIterationCount 1088 = 1 +encodeIterationCount 1152 = 2 +encodeIterationCount 1216 = 3 +encodeIterationCount 1280 = 4 +encodeIterationCount 1344 = 5 +encodeIterationCount 1408 = 6 +encodeIterationCount 1472 = 7 +encodeIterationCount 1536 = 8 +encodeIterationCount 1600 = 9 +encodeIterationCount 1664 = 10 +encodeIterationCount 1728 = 11 +encodeIterationCount 1792 = 12 +encodeIterationCount 1856 = 13 +encodeIterationCount 1920 = 14 +encodeIterationCount 1984 = 15 +encodeIterationCount 2048 = 16 +encodeIterationCount 2176 = 17 +encodeIterationCount 2304 = 18 +encodeIterationCount 2432 = 19 +encodeIterationCount 2560 = 20 +encodeIterationCount 2688 = 21 +encodeIterationCount 2816 = 22 +encodeIterationCount 2944 = 23 +encodeIterationCount 3072 = 24 +encodeIterationCount 3200 = 25 +encodeIterationCount 3328 = 26 +encodeIterationCount 3456 = 27 +encodeIterationCount 3584 = 28 +encodeIterationCount 3712 = 29 +encodeIterationCount 3840 = 30 +encodeIterationCount 3968 = 31 +encodeIterationCount 4096 = 32 +encodeIterationCount 4352 = 33 +encodeIterationCount 4608 = 34 +encodeIterationCount 4864 = 35 +encodeIterationCount 5120 = 36 +encodeIterationCount 5376 = 37 +encodeIterationCount 5632 = 38 +encodeIterationCount 5888 = 39 +encodeIterationCount 6144 = 40 +encodeIterationCount 6400 = 41 +encodeIterationCount 6656 = 42 +encodeIterationCount 6912 = 43 +encodeIterationCount 7168 = 44 +encodeIterationCount 7424 = 45 +encodeIterationCount 7680 = 46 +encodeIterationCount 7936 = 47 +encodeIterationCount 8192 = 48 +encodeIterationCount 8704 = 49 +encodeIterationCount 9216 = 50 +encodeIterationCount 9728 = 51 +encodeIterationCount 10240 = 52 +encodeIterationCount 10752 = 53 +encodeIterationCount 11264 = 54 +encodeIterationCount 11776 = 55 +encodeIterationCount 12288 = 56 +encodeIterationCount 12800 = 57 +encodeIterationCount 13312 = 58 +encodeIterationCount 13824 = 59 +encodeIterationCount 14336 = 60 +encodeIterationCount 14848 = 61 +encodeIterationCount 15360 = 62 +encodeIterationCount 15872 = 63 +encodeIterationCount 16384 = 64 +encodeIterationCount 17408 = 65 +encodeIterationCount 18432 = 66 +encodeIterationCount 19456 = 67 +encodeIterationCount 20480 = 68 +encodeIterationCount 21504 = 69 +encodeIterationCount 22528 = 70 +encodeIterationCount 23552 = 71 +encodeIterationCount 24576 = 72 +encodeIterationCount 25600 = 73 +encodeIterationCount 26624 = 74 +encodeIterationCount 27648 = 75 +encodeIterationCount 28672 = 76 +encodeIterationCount 29696 = 77 +encodeIterationCount 30720 = 78 +encodeIterationCount 31744 = 79 +encodeIterationCount 32768 = 80 +encodeIterationCount 34816 = 81 +encodeIterationCount 36864 = 82 +encodeIterationCount 38912 = 83 +encodeIterationCount 40960 = 84 +encodeIterationCount 43008 = 85 +encodeIterationCount 45056 = 86 +encodeIterationCount 47104 = 87 +encodeIterationCount 49152 = 88 +encodeIterationCount 51200 = 89 +encodeIterationCount 53248 = 90 +encodeIterationCount 55296 = 91 +encodeIterationCount 57344 = 92 +encodeIterationCount 59392 = 93 +encodeIterationCount 61440 = 94 +encodeIterationCount 63488 = 95 +encodeIterationCount 65536 = 96 +encodeIterationCount 69632 = 97 +encodeIterationCount 73728 = 98 +encodeIterationCount 77824 = 99 +encodeIterationCount 81920 = 100 +encodeIterationCount 86016 = 101 +encodeIterationCount 90112 = 102 +encodeIterationCount 94208 = 103 +encodeIterationCount 98304 = 104 +encodeIterationCount 102400 = 105 +encodeIterationCount 106496 = 106 +encodeIterationCount 110592 = 107 +encodeIterationCount 114688 = 108 +encodeIterationCount 118784 = 109 +encodeIterationCount 122880 = 110 +encodeIterationCount 126976 = 111 +encodeIterationCount 131072 = 112 +encodeIterationCount 139264 = 113 +encodeIterationCount 147456 = 114 +encodeIterationCount 155648 = 115 +encodeIterationCount 163840 = 116 +encodeIterationCount 172032 = 117 +encodeIterationCount 180224 = 118 +encodeIterationCount 188416 = 119 +encodeIterationCount 196608 = 120 +encodeIterationCount 204800 = 121 +encodeIterationCount 212992 = 122 +encodeIterationCount 221184 = 123 +encodeIterationCount 229376 = 124 +encodeIterationCount 237568 = 125 +encodeIterationCount 245760 = 126 +encodeIterationCount 253952 = 127 +encodeIterationCount 262144 = 128 +encodeIterationCount 278528 = 129 +encodeIterationCount 294912 = 130 +encodeIterationCount 311296 = 131 +encodeIterationCount 327680 = 132 +encodeIterationCount 344064 = 133 +encodeIterationCount 360448 = 134 +encodeIterationCount 376832 = 135 +encodeIterationCount 393216 = 136 +encodeIterationCount 409600 = 137 +encodeIterationCount 425984 = 138 +encodeIterationCount 442368 = 139 +encodeIterationCount 458752 = 140 +encodeIterationCount 475136 = 141 +encodeIterationCount 491520 = 142 +encodeIterationCount 507904 = 143 +encodeIterationCount 524288 = 144 +encodeIterationCount 557056 = 145 +encodeIterationCount 589824 = 146 +encodeIterationCount 622592 = 147 +encodeIterationCount 655360 = 148 +encodeIterationCount 688128 = 149 +encodeIterationCount 720896 = 150 +encodeIterationCount 753664 = 151 +encodeIterationCount 786432 = 152 +encodeIterationCount 819200 = 153 +encodeIterationCount 851968 = 154 +encodeIterationCount 884736 = 155 +encodeIterationCount 917504 = 156 +encodeIterationCount 950272 = 157 +encodeIterationCount 983040 = 158 +encodeIterationCount 1015808 = 159 +encodeIterationCount 1048576 = 160 +encodeIterationCount 1114112 = 161 +encodeIterationCount 1179648 = 162 +encodeIterationCount 1245184 = 163 +encodeIterationCount 1310720 = 164 +encodeIterationCount 1376256 = 165 +encodeIterationCount 1441792 = 166 +encodeIterationCount 1507328 = 167 +encodeIterationCount 1572864 = 168 +encodeIterationCount 1638400 = 169 +encodeIterationCount 1703936 = 170 +encodeIterationCount 1769472 = 171 +encodeIterationCount 1835008 = 172 +encodeIterationCount 1900544 = 173 +encodeIterationCount 1966080 = 174 +encodeIterationCount 2031616 = 175 +encodeIterationCount 2097152 = 176 +encodeIterationCount 2228224 = 177 +encodeIterationCount 2359296 = 178 +encodeIterationCount 2490368 = 179 +encodeIterationCount 2621440 = 180 +encodeIterationCount 2752512 = 181 +encodeIterationCount 2883584 = 182 +encodeIterationCount 3014656 = 183 +encodeIterationCount 3145728 = 184 +encodeIterationCount 3276800 = 185 +encodeIterationCount 3407872 = 186 +encodeIterationCount 3538944 = 187 +encodeIterationCount 3670016 = 188 +encodeIterationCount 3801088 = 189 +encodeIterationCount 3932160 = 190 +encodeIterationCount 4063232 = 191 +encodeIterationCount 4194304 = 192 +encodeIterationCount 4456448 = 193 +encodeIterationCount 4718592 = 194 +encodeIterationCount 4980736 = 195 +encodeIterationCount 5242880 = 196 +encodeIterationCount 5505024 = 197 +encodeIterationCount 5767168 = 198 +encodeIterationCount 6029312 = 199 +encodeIterationCount 6291456 = 200 +encodeIterationCount 6553600 = 201 +encodeIterationCount 6815744 = 202 +encodeIterationCount 7077888 = 203 +encodeIterationCount 7340032 = 204 +encodeIterationCount 7602176 = 205 +encodeIterationCount 7864320 = 206 +encodeIterationCount 8126464 = 207 +encodeIterationCount 8388608 = 208 +encodeIterationCount 8912896 = 209 +encodeIterationCount 9437184 = 210 +encodeIterationCount 9961472 = 211 +encodeIterationCount 10485760 = 212 +encodeIterationCount 11010048 = 213 +encodeIterationCount 11534336 = 214 +encodeIterationCount 12058624 = 215 +encodeIterationCount 12582912 = 216 +encodeIterationCount 13107200 = 217 +encodeIterationCount 13631488 = 218 +encodeIterationCount 14155776 = 219 +encodeIterationCount 14680064 = 220 +encodeIterationCount 15204352 = 221 +encodeIterationCount 15728640 = 222 +encodeIterationCount 16252928 = 223 +encodeIterationCount 16777216 = 224 +encodeIterationCount 17825792 = 225 +encodeIterationCount 18874368 = 226 +encodeIterationCount 19922944 = 227 +encodeIterationCount 20971520 = 228 +encodeIterationCount 22020096 = 229 +encodeIterationCount 23068672 = 230 +encodeIterationCount 24117248 = 231 +encodeIterationCount 25165824 = 232 +encodeIterationCount 26214400 = 233 +encodeIterationCount 27262976 = 234 +encodeIterationCount 28311552 = 235 +encodeIterationCount 29360128 = 236 +encodeIterationCount 30408704 = 237 +encodeIterationCount 31457280 = 238 +encodeIterationCount 32505856 = 239 +encodeIterationCount 33554432 = 240 +encodeIterationCount 35651584 = 241 +encodeIterationCount 37748736 = 242 +encodeIterationCount 39845888 = 243 +encodeIterationCount 41943040 = 244 +encodeIterationCount 44040192 = 245 +encodeIterationCount 46137344 = 246 +encodeIterationCount 48234496 = 247 +encodeIterationCount 50331648 = 248 +encodeIterationCount 52428800 = 249 +encodeIterationCount 54525952 = 250 +encodeIterationCount 56623104 = 251 +encodeIterationCount 58720256 = 252 +encodeIterationCount 60817408 = 253 +encodeIterationCount 62914560 = 254 +encodeIterationCount 65011712 = 255 +encodeIterationCount n = error "invalid iteration count" getSignaturePayload :: Get SignaturePayload getSignaturePayload = do 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 @@ -19,18 +19,14 @@ , ImageFormat(..) , PKPayload(..) , SKAddendum(..) - , ArmorType(..) - , Armor(Armor) , DataType(..) , PKey(..) , SKey(..) , EightOctetKeyId(..) , TwentyOctetFingerprint(..) - , TK(..) - , SessionKey + , KRK(..) , FutureFlag , FutureVal - , ArmorHeader , Keyring , fromFVal , fromFFlag @@ -68,7 +64,6 @@ type SignaturePacketBody = ByteString type SignatureHash = ByteString type PacketVersion = Word8 -type SessionKey = ByteString type Salt = ByteString type Count = Int type V3Expiration = Word16 @@ -426,9 +421,9 @@ toFVal 0x75 = UTF8Data toFVal o = OtherData o -data Packet = PKESK PacketVersion EightOctetKeyId PubKeyAlgorithm SessionKey +data Packet = PKESK PacketVersion EightOctetKeyId PubKeyAlgorithm [MPI] | Signature SignaturePayload - | SKESK PacketVersion SymmetricAlgorithm S2K (Maybe SessionKey) + | SKESK PacketVersion SymmetricAlgorithm S2K [MPI] | OnePassSignature PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag | SecretKey PKPayload SKAddendum | PublicKey PKPayload @@ -535,19 +530,6 @@ toFVal 0x50 = ThirdPartyConfirmationSig toFVal o = OtherSig o -data ArmorType a = ArmorMessage - | ArmorPublicKeyBlock - | ArmorPrivateKeyBlock - | ArmorSplitMessage a a - | ArmorSplitMessageIndefinite a - | ArmorSignature - deriving (Show, Eq) - -type ArmorHeader = (ByteString, ByteString) - -data Armor a = Armor (ArmorType a) [ArmorHeader] [Packet] - deriving (Show, Eq) - data PKey = RSAPubKey RSA.PublicKey | DSAPubKey DSA.PublicKey | ElGamalPubKey [Integer] @@ -582,7 +564,7 @@ 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 +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 deriving (Eq, Show) -type Keyring = Map EightOctetKeyId TK +type Keyring = Map EightOctetKeyId KRK diff --git a/Data/Conduit/Cereal/Temp.hs b/Data/Conduit/Cereal/Temp.hs deleted file mode 100644 --- a/Data/Conduit/Cereal/Temp.hs +++ /dev/null @@ -1,31 +0,0 @@ -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 --- a/Data/Conduit/OpenPGP/Compression.hs +++ b/Data/Conduit/OpenPGP/Compression.hs @@ -1,4 +1,4 @@ --- ASCIIArmor.hs: OpenPGP (RFC4880) ASCII armor implementation +-- Compression.hs: OpenPGP (RFC4880) compression conduits -- Copyright Ⓒ 2012 Clint Adams -- This software is released under the terms of the Expat (MIT) license. -- (See the LICENSE file). @@ -13,11 +13,11 @@ import Data.Conduit import qualified Data.Conduit.List as CL -conduitCompress :: ResourceThrow m => CompressionAlgorithm -> Conduit Packet m Packet +conduitCompress :: MonadThrow 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 :: MonadThrow m => Conduit Packet m Packet conduitDecompress = CL.concatMap decompressPacket 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 @@ -4,7 +4,7 @@ -- (See the LICENSE file). module Data.Conduit.OpenPGP.Keyring ( - conduitToTKs + conduitToKRKs , sinkKeyringMap ) where @@ -20,8 +20,8 @@ data Phase = MainKey | Revs | Uids | UAts | Subs deriving (Eq, Ord, Show) -conduitToTKs :: Resource m => Conduit Packet m TK -conduitToTKs = conduitState (MainKey, NoTK) push close +conduitToKRKs :: MonadResource m => Conduit Packet m KRK +conduitToKRKs = conduitState (MainKey, NoKRK) push close where push state input = case (state, input) of ((MainKey, _), PublicKey pkp) -> return $ StateProducing (Revs, TPK pkp [] [] [] []) [] @@ -31,14 +31,14 @@ ((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), 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)]) [] + ((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)])) [] + ((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)) [] @@ -49,14 +49,14 @@ ((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), 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)]) [] + ((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)])) [] + ((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)) [] @@ -73,11 +73,13 @@ sType (SigV4 st _ _ _ _ _ _) = st -sinkKeyringMap :: Resource m => Sink TK m (Map EightOctetKeyId TK) +sinkKeyringMap :: MonadResource m => Sink KRK m (Map EightOctetKeyId KRK) 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 :: 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 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 @@ -40,7 +40,7 @@ , lastSubkey :: Packet } -conduitVerify :: Resource m => Keyring -> Conduit Packet m (Either String Bool) +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 where push state ld@(LiteralData _ _ _ _) = return $ StateProducing (state { lastLD = ld }) [] diff --git a/Data/Digest/CRC24.hs b/Data/Digest/CRC24.hs deleted file mode 100644 --- a/Data/Digest/CRC24.hs +++ /dev/null @@ -1,25 +0,0 @@ --- CRC24.hs: OpenPGP (RFC4880) CRC24 implementation --- Copyright Ⓒ 2012 Clint Adams --- This software is released under the terms of the Expat (MIT) license. --- (See the LICENSE file). - -module Data.Digest.CRC24 ( - crc24 -) where - -import Data.Bits (shiftL, (.&.), xor) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Word (Word8, Word32) - -crc24_init :: Word32 -crc24_init = 0xB704CE - -crc24_poly :: Word32 -crc24_poly = 0x1864CFB - -crc24_update :: Word32 -> Word8 -> Word32 -crc24_update c b = (last . take 9 $ iterate (\x -> if (shiftL x 1) .&. 0x1000000 == 0x1000000 then shiftL x 1 `xor` crc24_poly else shiftL x 1) (c `xor` shiftL (fromIntegral b) 16)) .&. 0xFFFFFF - -crc24 :: ByteString -> Word32 -crc24 bs = B.foldl crc24_update crc24_init bs diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.2 +Version: 0.3 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -95,6 +95,8 @@ , tests/data/msg1.asc , tests/data/uncompressed-ops-rsa.gpg , tests/data/uncompressed-ops-dsa.gpg + , tests/data/uncompressed-ops-dsa-sha384.txt.gpg + , tests/data/encryption.gpg Cabal-version: >= 1.10 @@ -102,18 +104,13 @@ Library 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 + Other-Modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.SerializeForSigs - , Data.Conduit.Cereal.Temp Build-depends: asn1-data , attoparsec , base > 4 && < 5 @@ -121,12 +118,13 @@ , bytestring , bzlib , cereal - , cereal-conduit < 0.0.4 - , conduit < 0.3.0 + , cereal-conduit > 0.0.6 && < 0.1 + , conduit > 0.4 && < 0.5 , containers , cryptocipher , cryptohash , mtl + , openpgp-asciiarmor >= 0.1 , split , zlib default-language: Haskell2010 @@ -142,17 +140,20 @@ , bytestring , bzlib , cereal - , cereal-conduit < 0.0.4 - , conduit < 0.3.0 + , cereal-conduit > 0.0.6 && < 0.1 + , conduit > 0.4 && < 0.5 , containers , cryptocipher , cryptohash , mtl + , openpgp-asciiarmor >= 0.1 , split , zlib , HUnit , test-framework , test-framework-hunit + , exception-transformers > 0.3 && < 0.4 + , resourcet > 0.3 && < 0.4 default-language: Haskell2010 source-repository head diff --git a/tests/data/encryption.gpg b/tests/data/encryption.gpg new file mode 100644 Binary files /dev/null and b/tests/data/encryption.gpg differ diff --git a/tests/data/uncompressed-ops-dsa-sha384.txt.gpg b/tests/data/uncompressed-ops-dsa-sha384.txt.gpg new file mode 100644 Binary files /dev/null and b/tests/data/uncompressed-ops-dsa-sha384.txt.gpg differ diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.HUnit @@ -6,18 +7,20 @@ import Test.HUnit 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.Cereal (conduitGet) import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress) -import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap) +import Data.Conduit.OpenPGP.Keyring (conduitToKRKs, sinkKeyringMap) import Data.Conduit.OpenPGP.Verify (conduitVerify) -import Data.ByteString (ByteString) +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 Data.Digest.CRC24 (crc24) +import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Serialize (get, put) @@ -29,6 +32,17 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL +-- cope with instance problem for now +instance (DC.MonadResource m, DC.MonadThrow (ExceptionT m)) => DC.MonadResource (ExceptionT m) where + allocate a = lift . allocate a + register = lift . register + release = lift . release + resourceMask = lift . resourceMask + +instance Monad a => DC.MonadThrow (ExceptionT a) where + monadThrow = throw +-- + testSerialization :: FilePath -> Assertion testSerialization fp = do bs <- B.readFile $ "tests/data/" ++ fp @@ -43,19 +57,6 @@ else assertEqual ("for " ++ fp) firstpass secondpass -testCRC24 :: ByteString -> Word32 -> Assertion -testCRC24 bs crc = assertEqual "crc24" crc (crc24 bs) - -testArmorDecode :: FilePath -> Armor Int -> Assertion -testArmorDecode fp target = do - bs <- B.readFile $ "tests/data/" ++ fp - case decodeArmor bs of - Left err -> assertFailure $ "Decode failed on " ++ fp - Right arm -> do assertEqual ("for " ++ fp) target arm - -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 @@ -70,10 +71,10 @@ else assertEqual ("for " ++ fp) firstpass secondpass -counter :: (DC.ResourceIO m) => DC.Sink a m Int +counter :: (DC.MonadResource m) => DC.Sink a m Int counter = CL.fold (const . (1+)) 0 -testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString IO b -> Int -> Assertion +testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString (DC.ResourceT 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 @@ -87,14 +88,26 @@ 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) + -- kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fp) DC.$= conduitGet get DC.$= conduitToKRKs DC.$$ sinkKeyringMap + -- let key = (Map.lookup (read eok) kr) + kr <- DC.runResourceT $ runExceptionT $ (CB.sourceFile ("tests/data/" ++ fp) DC.$= conduitGet get DC.$= conduitToKRKs DC.$$ sinkKeyringMap :: ExceptionT (DC.ResourceT IO) (Map.Map EightOctetKeyId KRK)) + let key = case kr of + Left e -> Nothing + Right k -> Map.lookup (read eok) k 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 + -- kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ keyring) DC.$= conduitGet get DC.$= conduitToKRKs DC.$$ sinkKeyringMap + -- verification <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr DC.$$ CL.consume + kring <- DC.runResourceT $ runExceptionT $ (CB.sourceFile ("tests/data/" ++ keyring) DC.$= conduitGet get DC.$= conduitToKRKs DC.$$ sinkKeyringMap :: ExceptionT (DC.ResourceT IO) (Map.Map EightOctetKeyId KRK)) + let kr = case kring of + Left e -> Map.empty + Right k -> k + verif <- DC.runResourceT $ runExceptionT $ (CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr DC.$$ CL.consume :: ExceptionT (DC.ResourceT IO) [Either String Bool]) + let verification = case verif of + Left e -> [] + Right xs -> xs assertEqual (keyring ++ " for " ++ message) ([Right True]) verification tests = [ @@ -186,36 +199,13 @@ , 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) - , testCase "CRC24: Haskell" (testCRC24 "Haskell" 15612750) - , testCase "CRC24: hOpenPGP and friends" (testCRC24 "hOpenPGP and friends" 11940960) - ], - 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 "pubsub AD992E9C24399832" (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True) , testCase "secring 7732CF988A63EA86" (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) , testCase "secring 123456789ABCDEF0" (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) + , testCase "secsub AD992E9C24399832" (testKeyringLookup "secring.gpg" "AD992E9C24399832" True) -- FIXME: should count keys in rings ], testGroup "Message verification group" [