hOpenPGP 2.9.4 → 2.9.5
raw patch · 4 files changed
+83/−76 lines, 4 filesdep −newtype
Dependencies removed: newtype
Files
- Codec/Encryption/OpenPGP/Signatures.hs +27/−10
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +28/−52
- Data/Conduit/OpenPGP/Filter.hs +20/−6
- hOpenPGP.cabal +8/−8
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -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]
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -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)
Data/Conduit/OpenPGP/Filter.hs view
@@ -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)
hOpenPGP.cabal view
@@ -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