diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -1,5 +1,5 @@ -- Signatures.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012-2019 Clint Adams +-- Copyright © 2012-2020 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Signatures @@ -239,23 +239,38 @@ let results = map (\pkp -> - verify' - sig + verifyAgainstKey' pkp - (hashalgo sig) - (BL.toStrict (finalPayload sig payload))) + sig + mt + payload) allrelevantpkps case rights results of [] -> Left (concatMap (++ "/") (lefts results)) [r] -> do _ <- isSignatureExpired sig mt - return (Verification r ((_signaturePayload . fromPkt) sig)) -- FIXME: this should also check expiration time and flags of the signing key + return r _ -> Left "multiple successes; unexpected condition" where subPKP (pack, _) = subPKP' pack subPKP' (PublicSubkeyPkt p) = p subPKP' (SecretSubkeyPkt p _) = p subPKP' _ = error "This should never happen (subPKP')" + +verifyAgainstKey' :: + PKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification +verifyAgainstKey' pkp sig mt payload = do +-- FIXME: check flags +-- FIXME: check expiration time + r <- verify' + sig + pkp + (hashalgo sig) + (BL.toStrict (finalPayload sig payload)) +-- FIXME: check signature hash against policy +-- FIXME: check pka against policy + return (Verification r ((_signaturePayload . fromPkt) sig)) + where verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA1 pl = verify'' (pkaAndMPIs s) CHA.SHA1 pub pkey pl verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) RIPEMD160 pl = @@ -317,20 +332,22 @@ hashalgo _ = error "This should never happen (hashalgo)." pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka, mpis) pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)." - isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool - isSignatureExpired _ Nothing = return False - isSignatureExpired s (Just t) = + crazyHash h = BA.convert . hashWith h + +isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool +isSignatureExpired _ Nothing = return False +isSignatureExpired s (Just t) = if any (expiredBefore t) ((\(SigV4 _ _ _ h _ _ _) -> h) . _signaturePayload . fromPkt $ s) then Left "signature expired" else return True + where expiredBefore :: UTCTime -> SigSubPacket -> Bool expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < 0 expiredBefore _ _ = False - crazyHash h = BA.convert . hashWith h finalPayload :: Pkt -> ByteString -> ByteString finalPayload s pl = BL.concat [pl, sigbit, trailer s] diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -17,9 +17,8 @@ import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS) import Control.Applicative ((<|>)) import Control.Arrow ((***)) -import Control.Lens (makeLenses) +import Control.Lens (makeLenses, op, Wrapped) import Control.Monad (mzero) -import Control.Newtype (Newtype(..)) import Data.Aeson ((.=), object) import qualified Data.Aeson as A import qualified Data.Aeson.TH as ATH @@ -213,9 +212,7 @@ , Typeable ) -instance Newtype ThirtyTwoBitTimeStamp Word32 where - pack = ThirtyTwoBitTimeStamp - unpack (ThirtyTwoBitTimeStamp o) = o +instance Wrapped ThirtyTwoBitTimeStamp instance Pretty ThirtyTwoBitTimeStamp where pretty = @@ -251,12 +248,10 @@ , Typeable ) -instance Newtype ThirtyTwoBitDuration Word32 where - pack = ThirtyTwoBitDuration - unpack (ThirtyTwoBitDuration o) = o +instance Wrapped ThirtyTwoBitDuration instance Pretty ThirtyTwoBitDuration where - pretty = pretty . concat . unfoldr durU . unpack + pretty = pretty . concat . unfoldr durU . op ThirtyTwoBitDuration $(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitDuration) @@ -352,9 +347,7 @@ } deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Newtype TwentyOctetFingerprint ByteString where - pack = TwentyOctetFingerprint - unpack (TwentyOctetFingerprint o) = o +instance Wrapped TwentyOctetFingerprint -- FIXME: read-show instance Read TwentyOctetFingerprint where @@ -378,10 +371,9 @@ SpacedFingerprint { unSpacedFingerprint :: TwentyOctetFingerprint } + deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Newtype SpacedFingerprint TwentyOctetFingerprint where - pack = SpacedFingerprint - unpack (SpacedFingerprint o) = o +instance Wrapped SpacedFingerprint instance Pretty SpacedFingerprint where pretty = @@ -389,7 +381,7 @@ punctuate space . map hsep . chunksOf 5 . - map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . unpack + map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . op SpacedFingerprint bsToHexUpper :: ByteString -> String bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode @@ -403,12 +395,10 @@ } deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Newtype EightOctetKeyId ByteString where - pack = EightOctetKeyId - unpack (EightOctetKeyId o) = o +instance Wrapped EightOctetKeyId instance Pretty EightOctetKeyId where - pretty = pretty . bsToHexUpper . unpack + pretty = pretty . bsToHexUpper . op EightOctetKeyId -- FIXME: read-show instance Read EightOctetKeyId where @@ -418,7 +408,7 @@ instance Hashable EightOctetKeyId instance A.ToJSON EightOctetKeyId where - toJSON e = object [T.pack "eoki" .= (bsToHexUpper . unpack) e] + toJSON e = object [T.pack "eoki" .= (bsToHexUpper . op EightOctetKeyId) e] instance A.FromJSON EightOctetKeyId where parseJSON (A.Object v) = EightOctetKeyId . read <$> v A..: T.pack "eoki" @@ -433,12 +423,10 @@ instance Pretty NotationName where pretty = prettyLBS . unNotationName -instance Newtype NotationName ByteString where - pack = NotationName - unpack (NotationName nn) = nn +instance Wrapped NotationName instance A.ToJSON NotationName where - toJSON nn = object [T.pack "notationname" .= show (unpack nn)] + toJSON nn = object [T.pack "notationname" .= show (op NotationName nn)] instance A.FromJSON NotationName where parseJSON (A.Object v) = NotationName . read <$> v A..: T.pack "notationname" @@ -453,12 +441,10 @@ instance Pretty NotationValue where pretty = prettyLBS . unNotationValue -instance Newtype NotationValue ByteString where - pack = NotationValue - unpack (NotationValue nv) = nv +instance Wrapped NotationValue instance A.ToJSON NotationValue where - toJSON nv = object [T.pack "notationvalue" .= show (unpack nv)] + toJSON nv = object [T.pack "notationvalue" .= show (op NotationValue nv)] instance A.FromJSON NotationValue where parseJSON (A.Object v) = @@ -702,9 +688,7 @@ } deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Newtype URL URI where - pack = URL - unpack (URL o) = o +instance Wrapped URL instance Hashable URL where hashWithSalt salt (URL (URI s a p q f)) = @@ -713,10 +697,10 @@ f instance Pretty URL where - pretty = pretty . (\uri -> uriToString id uri "") . unpack + pretty = pretty . (\uri -> uriToString id uri "") . op URL instance A.ToJSON URL where - toJSON u = object [T.pack "uri" .= (\uri -> uriToString id uri "") (unpack u)] + toJSON u = object [T.pack "uri" .= (\uri -> uriToString id uri "") (op URL u)] instance A.FromJSON URL where parseJSON (A.Object v) = @@ -810,14 +794,12 @@ } deriving (Data, Eq, Generic, Show, Typeable) -instance Newtype MPI Integer where - pack = MPI - unpack (MPI o) = o +instance Wrapped MPI instance Hashable MPI instance Pretty MPI where - pretty = pretty . unpack + pretty = pretty . op MPI $(ATH.deriveJSON ATH.defaultOptions ''MPI) @@ -1055,15 +1037,13 @@ , Typeable ) -instance Newtype IV B.ByteString where - pack = IV - unpack (IV o) = o +instance Wrapped IV instance Pretty IV where - pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . unpack + pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . op IV instance A.ToJSON IV where - toJSON = A.toJSON . show . unpack + toJSON = A.toJSON . show . op IV data DataType = BinaryData @@ -1104,15 +1084,13 @@ } deriving (Data, Eq, Generic, Hashable, Show, Typeable) -instance Newtype Salt B.ByteString where - pack = Salt - unpack (Salt o) = o +instance Wrapped Salt instance Pretty Salt where - pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . unpack + pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . op Salt instance A.ToJSON Salt where - toJSON = A.toJSON . show . unpack + toJSON = A.toJSON . show . op Salt newtype IterationCount = IterationCount @@ -1132,12 +1110,10 @@ , Typeable ) -instance Newtype IterationCount Int where - pack = IterationCount - unpack (IterationCount o) = o +instance Wrapped IterationCount instance Pretty IterationCount where - pretty = pretty . unpack + pretty = pretty . op IterationCount $(ATH.deriveJSON ATH.defaultOptions ''IterationCount) 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 @@ -1,11 +1,12 @@ -- Filter.hs: OpenPGP (RFC4880) packet filtering --- Copyright © 2014-2018 Clint Adams +-- Copyright © 2014-2020 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE GADTs #-} module Data.Conduit.OpenPGP.Filter ( conduitPktFilter + , conduitPktWithExtraFilter , conduitTKFilter , FilterPredicates(..) ) where @@ -13,22 +14,35 @@ import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (ConduitT) import qualified Data.Conduit.List as CL +import Data.Void (Void) import Codec.Encryption.OpenPGP.Types -data FilterPredicates +data FilterPredicates r a = RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets + | RFilterPredicate (Reader a Bool) -- ^ generic filter predicate + | RPairFilterPredicate (Reader (r, a) Bool) -- ^ generic filter predicate with additional context -conduitPktFilter :: Monad m => FilterPredicates -> ConduitT Pkt Pkt m () +conduitPktFilter :: + Monad m => FilterPredicates Void Pkt -> ConduitT Pkt Pkt m () conduitPktFilter = CL.filter . superPredicate -superPredicate :: FilterPredicates -> Pkt -> Bool +superPredicate :: FilterPredicates Void Pkt -> Pkt -> Bool superPredicate (RPFilterPredicate e) p = runReader e p +superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet -conduitTKFilter :: Monad m => FilterPredicates -> ConduitT TK TK m () +conduitTKFilter :: Monad m => FilterPredicates Void TK -> ConduitT TK TK m () conduitTKFilter = CL.filter . superTKPredicate -superTKPredicate :: FilterPredicates -> TK -> Bool +superTKPredicate :: FilterPredicates Void TK -> TK -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e +superTKPredicate (RFilterPredicate e) = runReader e + +conduitPktWithExtraFilter :: + Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m () +conduitPktWithExtraFilter extra = CL.filter . superPairPredicate extra + +superPairPredicate :: r -> FilterPredicates r a -> a -> Bool +superPairPredicate r (RPairFilterPredicate e) p = runReader e (r, p) diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 2.9.4 +Version: 2.9.5 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581), plus ECC (RFC6637) Homepage: https://salsa.debian.org/clint/hOpenPGP @@ -218,11 +218,9 @@ , memory , monad-loops , nettle - , newtype , openpgp-asciiarmor >= 0.1 , prettyprinter , resourcet > 0.4 - , semigroups , split , text , time >= 1.1 @@ -231,6 +229,8 @@ , unliftio-core , unordered-containers , zlib + if impl(ghc < 8.0) + build-depends: semigroups if flag(network-uri) build-depends: network-uri >= 2.6 else @@ -267,9 +267,7 @@ , memory , monad-loops , nettle - , newtype , prettyprinter - , semigroups , split , text , time >= 1.1 @@ -284,6 +282,8 @@ , QuickCheck > 2.9 , quickcheck-instances , resourcet > 0.4 + if impl(ghc < 8.0) + build-depends: semigroups if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else @@ -316,11 +316,9 @@ , memory , monad-loops , nettle - , newtype , openpgp-asciiarmor >= 0.1 , prettyprinter , resourcet > 0.4 - , semigroups , split , text , time >= 1.1 @@ -330,6 +328,8 @@ , unordered-containers , zlib , criterion > 0.8 + if impl(ghc < 8.0) + build-depends: semigroups if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else @@ -343,4 +343,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v2.9.4 + tag: v2.9.5