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 @@ -185,8 +185,8 @@ return $ SigSubPacket crit (TrustSignature tl ta) | pt == 6 = do apdre <- getByteString (l - 2) - nul <- getWord8 - guard (nul == 0) + nul <- getWord8 + guard (nul == 0) return $ SigSubPacket crit (RegularExpression (B.copy apdre)) | pt == 7 = do r <- get @@ -250,7 +250,7 @@ hash <- getByteString (l - 3) return $ SigSubPacket crit (SignatureTarget pka ha hash) | pt == 32 = do - sp <- get :: Get SignaturePayload + sp <- get :: Get SignaturePayload return $ SigSubPacket crit (EmbeddedSignature sp) | pt > 99 && pt < 111 = do payload <- getByteString (l - 1) @@ -472,7 +472,10 @@ salt <- getByteString 8 count <- getWord8 return $ IteratedSalted (toFVal ha) salt (decodeIterationCount count) - | otherwise = error "Unknown S2K" + | otherwise = do + len <- remaining + bs <- getByteString len + return $ OtherS2K t bs putS2K :: S2K -> Put putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo) @@ -482,6 +485,7 @@ put ha putByteString salt putWord8 $ encodeIterationCount count +putS2K (OtherS2K t bs) = putWord8 t >> putByteString bs getPacketTypeAndPayload :: Get (Word8, ByteString) getPacketTypeAndPayload = do @@ -846,16 +850,22 @@ return $ SUUnencrypted sk checksum 255 -> do symenc <- getWord8 s2k <- getS2K - iv <- getByteString (symEncBlockSize . toFVal $ symenc) - remainder <- remaining - encryptedblock <- getByteString remainder - return $ SUS16bit (toFVal symenc) s2k iv encryptedblock + case s2k of -- FIXME: this is a mess + OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k B.empty B.empty + _ -> do + iv <- getByteString (symEncBlockSize . toFVal $ symenc) + remainder <- remaining + encryptedblock <- getByteString remainder + return $ SUS16bit (toFVal symenc) s2k iv encryptedblock 254 -> do symenc <- getWord8 s2k <- getS2K - iv <- getByteString (symEncBlockSize . toFVal $ symenc) - remainder <- remaining - encryptedblock <- getByteString remainder - return $ SUSSHA1 (toFVal symenc) s2k iv encryptedblock + case s2k of -- FIXME: this is a mess + OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k B.empty B.empty + _ -> do + iv <- getByteString (symEncBlockSize . toFVal $ symenc) + remainder <- remaining + encryptedblock <- getByteString remainder + return $ SUSSHA1 (toFVal symenc) s2k iv encryptedblock symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining encryptedblock <- getByteString remainder 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,6 +19,7 @@ import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.IxSet (IxSet) +import Data.List (intercalate) import Data.List.Split (chunksOf) import Data.Monoid ((<>)) import Data.Ord (comparing) @@ -27,6 +28,7 @@ import Data.Typeable (Typeable) import Data.Word (Word8, Word16, Word32) import Numeric (readHex, showHex) +import Text.PrettyPrint.ANSI.Leijen (Pretty(..), (<+>), hsep, space, text) type TimeStamp = Word32 type Exportability = Bool @@ -619,12 +621,20 @@ deriving (Data, Eq, Generic, Ord, Typeable) instance Show TwentyOctetFingerprint where - show = take 50 . concatMap (++" ") . concatMap (++[""]) . chunksOf 5 . chunksOf 4 . w8sToHex . B.unpack . unTOF + show = w8sToHex . B.unpack . unTOF instance Read TwentyOctetFingerprint where readsPrec _ = map ((TwentyOctetFingerprint . B.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ') instance Hashable TwentyOctetFingerprint + +instance Pretty TwentyOctetFingerprint where + pretty = hsep . intercalate [space] . chunksOf 5 . map text . chunksOf 4 . take 40 . w8sToHex . B.unpack . unTOF + +newtype SpacedFingerprint = SpacedFingerprint { unSpacedFingerprint :: TwentyOctetFingerprint } + +instance Show SpacedFingerprint where + show = take 50 . concatMap (++" ") . concatMap (++[""]) . chunksOf 5 . chunksOf 4 . show . unSpacedFingerprint w8sToHex :: [Word8] -> String w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "") diff --git a/Data/Conduit/OpenPGP/Filter.hs b/Data/Conduit/OpenPGP/Filter.hs --- a/Data/Conduit/OpenPGP/Filter.hs +++ b/Data/Conduit/OpenPGP/Filter.hs @@ -3,31 +3,34 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs, RecordWildCards #-} module Data.Conduit.OpenPGP.Filter ( - conduitFilter - , conduitPktFilter + conduitPktFilter , conduitTKFilter , FilterPredicates(..) , Expr(..) - , PKPPredicate(..) , PKPVar(..) , PKPOp(..) , PKPValue(..) - , SPPredicate(..) , SPVar(..) , SPOp(..) , SPValue(..) - , OPredicate(..) , OVar(..) , OOp(..) , OValue(..) , UPredicate(..) , UOp(..) + , Exp(..) + , unop + , binop ) where +import Control.Applicative (Applicative, (<$>), (<*>), pure) import Control.Error.Util (hush) +import Control.Monad ((>=>)) +import Control.Monad.Loops (allM, anyM) +import Control.Monad.Reader (ask, reader, runReader, Reader) import Control.Monad.Trans.Resource (MonadResource) import qualified Data.ByteString as B import Data.Conduit @@ -40,14 +43,11 @@ import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) import Codec.Encryption.OpenPGP.Types -{-# DEPRECATED conduitFilter "Use conduitPktFilter instead" #-} -{-# DEPRECATED PKPPredicate, SPPredicate, OPredicate "Use UPredicate instead" #-} -data FilterPredicates = FilterPredicates { - _pubKeyPktPredicate :: Expr PKPPredicate - , _sigPktPredicate :: Expr SPPredicate - , _otherPredicate :: Expr OPredicate -} | UnifiedFilterPredicate (Expr UPredicate) +data FilterPredicates = + UnifiedFilterPredicate (Expr UPredicate) -- ^ "old"-style filter predicate, hopefully to be deprecated + | TransitionalTKFP (Exp (Reader TK) Bool) -- ^ a more flexible fp for transferable keys + | TransitionalUFP (Exp (Reader Pkt) Bool) -- ^ a more flexible fp for context-less packets data Expr a = EAny | E a @@ -134,26 +134,25 @@ | USPP SPVar UOp SPValue | UOP OVar UOp OValue -data UOp = UEquals | ULessThan | UGreaterThan +data UOp = UEquals -- ^ (==) + | ULessThan -- ^ (<) + | UGreaterThan -- ^ (>) deriving Enum -conduitFilter :: Monad m => FilterPredicates -> Conduit Pkt m Pkt -conduitFilter = conduitPktFilter - conduitPktFilter :: Monad m => FilterPredicates -> Conduit Pkt m Pkt conduitPktFilter = CL.filter . superPredicate superPredicate :: FilterPredicates -> Pkt -> Bool -superPredicate fp@FilterPredicates{..} (PublicKeyPkt pkp) = eval pkpEval _pubKeyPktPredicate pkp -superPredicate fp@FilterPredicates{..} (SignaturePkt sp) = eval spEval _sigPktPredicate sp -superPredicate fp@FilterPredicates{..} p = eval oEval _otherPredicate p superPredicate (UnifiedFilterPredicate ufp) p = eval uEval ufp p +superPredicate (TransitionalUFP e) p = runReader (evalM e) p +superPredicate _ _ = False -- do not match incorrect type of packet conduitTKFilter :: Monad m => FilterPredicates -> Conduit TK m TK conduitTKFilter = CL.filter . superTKPredicate superTKPredicate :: FilterPredicates -> TK -> Bool superTKPredicate (UnifiedFilterPredicate ufp) p = eval uEval ufp (PublicKeyPkt (fst (_tkKey p))) -- FIXME: should operate on more than just the pkp +superTKPredicate (TransitionalTKFP e) k = runReader (evalM e) k pkpEval :: PKPPredicate -> PKPayload -> Bool pkpEval (PKPPredicate lhs o rhs) pkp = uncurry (opreduce o) (vreduce (lhs,pkp),rhs) @@ -200,3 +199,29 @@ uEval (USPP l o r) (SignaturePkt s) = spEval (SPPredicate l (toEnum . fromEnum $ o) r) s uEval (UOP l o r) pkt = oEval (OPredicate l (toEnum . fromEnum $ o) r) pkt uEval _ _ = False -- do not match packets of wrong type + +-- + +data Exp m a where + I :: Integer -> Exp m Integer + B :: Bool -> Exp m Bool + S :: String -> Exp m String + Lift :: b -> Exp m b + Ap :: Exp m (b -> c) -> Exp m b -> Exp m c + AnyAll :: ((b -> m Bool) -> [b] -> m Bool) -> (b -> Exp m Bool) -> Exp m [b] -> Exp m Bool + MA :: m b -> Exp m b + +evalM :: (Functor m, Applicative m, Monad m) => Exp m a -> m a +evalM (I n) = return n +evalM (B b) = return b +evalM (S s) = return s +evalM (Lift l) = return l +evalM (MA a) = a +evalM (Ap f a) = evalM f <*> evalM a +evalM (AnyAll aa f l) = evalM l >>= (aa (evalM . f) >=> return) + +unop :: (a -> b) -> Exp m a -> Exp m b +unop = Ap . Lift + +binop :: (a -> a -> b) -> Exp m a -> Exp m a -> Exp m b +binop = (Ap .) . Ap . Lift diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 1.9 +Version: 1.10 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -140,6 +140,7 @@ , tests/data/revoked.pubkey , tests/data/expired.pubkey , tests/data/sigs-with-regexes + , tests/data/gnu-dummy-s2k-101-secret-key.gpg Cabal-version: >= 1.10 @@ -167,6 +168,7 @@ , Codec.Encryption.OpenPGP.SerializeForSigs , Codec.Encryption.OpenPGP.BlockCipher Build-depends: attoparsec + , ansi-wl-pprint >= 0.6.7 , base > 4 && < 5 , base64-bytestring , bytestring @@ -209,8 +211,9 @@ other-modules: Codec.Encryption.OpenPGP.Arbitrary Ghc-options: -Wall Build-depends: hOpenPGP - , base > 4 && < 5 + , ansi-wl-pprint >= 0.6.7 , attoparsec + , base > 4 && < 5 , bytestring , bzlib , cereal @@ -255,4 +258,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v1.9 + tag: v1.10 diff --git a/tests/data/gnu-dummy-s2k-101-secret-key.gpg b/tests/data/gnu-dummy-s2k-101-secret-key.gpg new file mode 100644 Binary files /dev/null and b/tests/data/gnu-dummy-s2k-101-secret-key.gpg differ diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -81,8 +81,12 @@ bs <- B.readFile $ "tests/data/" ++ fpr case runGet (get :: Get Pkt) bs of Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." - Right (PublicKeyPkt pkp) -> assertEqual ("for " ++ fpr) kf (either (const "unknown") show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) + Right (PublicKeyPkt pkp) -> do + assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (either (const "unknown") show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) + assertEqual ("for " ++ fpr ++ " (spaced)") kf (either (const "unknown") show (eightOctetKeyID pkp) ++ "/" ++ show (SpacedFingerprint (fingerprint pkp))) _ -> assertFailure "Expected public key, got something else." + where + spaceless = filter (/=' ') testKeyringLookup :: FilePath -> String -> Bool -> Assertion testKeyringLookup fpr eok expected = do @@ -248,6 +252,7 @@ , testCase "simple.seckey" (testSerialization "simple.seckey") , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig") , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes") + , testCase "gnu-dummy-s2k-101-secret-key.gpg" (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") ], testGroup "KeyID/fingerprint group" [ testCase "v3 key" (testKeyIDandFingerprint "v3.key" "C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E ")