hOpenPGP 2.0 → 2.1
raw patch · 6 files changed
+208/−125 lines, 6 filesdep ~time
Dependency ranges changed: time
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +6/−0
- Codec/Encryption/OpenPGP/SecretKey.hs +2/−3
- Codec/Encryption/OpenPGP/Serialize.hs +49/−71
- Codec/Encryption/OpenPGP/Types.hs +148/−48
- hOpenPGP.cabal +2/−2
- tests/suite.hs +1/−1
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -151,6 +151,12 @@ instance Arbitrary ThirtyTwoBitDuration where arbitrary = liftM ThirtyTwoBitDuration arbitrary +instance Arbitrary NotationName where+ arbitrary = liftM NotationName arbitrary++instance Arbitrary NotationValue where+ arbitrary = liftM NotationValue arbitrary+ -- FIXME: this should be elsewhere instance Arbitrary a => Arbitrary (NE.NonEmpty a) where arbitrary = NE.fromList `liftM` listOf1 arbitrary
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -15,13 +15,12 @@ import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce) import Codec.Encryption.OpenPGP.Serialize (getSecretKey) import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)-import Control.Monad ((>=>)) import qualified Crypto.Hash.SHA1 as SHA1 import Crypto.Random (createEntropyPool, cprgCreate, cprgGenerateWithEntropy, SystemRNG) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Binary (put)-import Data.Binary.Get (getLazyByteString, remaining, getWord16be, runGetOrFail)+import Data.Binary.Get (getRemainingLazyByteString, getWord16be, runGetOrFail) import Data.Binary.Put (runPut) import Data.Bifunctor (bimap) import qualified Crypto.PubKey.RSA as R@@ -48,7 +47,7 @@ let checksum = sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum? where- getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> remaining >>= (getLazyByteString >=> \csum -> return (sk, csum))) (BL.fromStrict p))+ getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> getRemainingLazyByteString >>= \csum -> return (sk, csum)) (BL.fromStrict p)) decryptSKA _ _ = Left "Unexpected codepath" -- |generates pseudo-random salt and IV
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -8,9 +8,9 @@ , getSecretKey ) where -import Control.Applicative ((<$>),(<*>), many, some)+import Control.Applicative ((<$>), many, some) import Control.Lens ((^.), _1)-import Control.Monad (guard, liftM, mplus, replicateM, replicateM_)+import Control.Monad (guard, liftM, replicateM, replicateM_) import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit)@@ -20,7 +20,7 @@ import Data.List (mapAccumL) import qualified Data.List.NonEmpty as NE import Data.Binary (Binary, get, put)-import Data.Binary.Get (Get, getWord8, getWord16be, getWord32be, getByteString, getLazyByteString, getWord16le, runGetOrFail, remaining, ByteOffset)+import Data.Binary.Get (Get, getByteString, getLazyByteString, getRemainingLazyByteString, getWord8, getWord16be, getWord32be, getWord16le, runGetOrFail, ByteOffset) import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, putWord16le, runPut) import qualified Data.Foldable as F import Data.Monoid (mempty)@@ -215,9 +215,9 @@ flags <- getLazyByteString 4 nl <- getWord16be vl <- getWord16be- nd <- getLazyByteString (fromIntegral nl)+ nn <- getLazyByteString (fromIntegral nl) nv <- getLazyByteString (fromIntegral vl)- return $ SigSubPacket crit (NotationData (bsToFFSet flags) nd nv)+ return $ SigSubPacket crit (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv)) | pt == 21 = do ha <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredHashAlgorithms ha)@@ -302,17 +302,17 @@ putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do putSubPacketLength 23 putSigSubPacketType crit 12- putLazyByteString . ffSetToFixedLengthBS 1 $ Set.insert (RClOther 0) rclass+ putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ Set.insert (RClOther 0) rclass put algid putLazyByteString (unTOF fp) -- 20 octets putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do putSubPacketLength 9 putSigSubPacketType crit 16 putLazyByteString (unEOKI keyid) -- 8 octets-putSigSubPacket (SigSubPacket crit (NotationData nfs nn nv)) = do+putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv) putSigSubPacketType crit 20- putLazyByteString . ffSetToFixedLengthBS 4 $ nfs+ putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs putWord16be . fromIntegral . BL.length $ nn putWord16be . fromIntegral . BL.length $ nv putLazyByteString nn@@ -375,10 +375,7 @@ putSubPacketLength . fromIntegral $ (1 + BL.length spb) putSigSubPacketType crit 32 putLazyByteString spb-putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = do- putSubPacketLength . fromIntegral $ (1 + BL.length payload)- putSigSubPacketType crit ptype- putLazyByteString payload+putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do putSubPacketLength . fromIntegral $ (1 + BL.length payload) putSigSubPacketType crit ptype@@ -415,7 +412,9 @@ putSigSubPacketType True sst = putWord8 (sst .|. 0x80) bsToFFSet :: FutureFlag a => ByteString -> Set a-bsToFFSet bs = Set.fromAscList . concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (\x -> if y .&. shiftR 128 x == shiftR 128 x then [toFFlag (acc + x)] else []) [0..7])) 0 (BL.unpack bs)+bsToFFSet bs = Set.fromAscList . concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (shifty acc y) [0..7])) 0 (BL.unpack bs)+ where+ shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x] ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString ffSetToFixedLengthBS len ffs = BL.take (fromIntegral len) (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))@@ -480,8 +479,7 @@ count <- getWord8 return $ IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count) | otherwise = do- len <- remaining- bs <- getLazyByteString len+ bs <- getRemainingLazyByteString return $ OtherS2K t bs putS2K :: S2K -> Put@@ -511,8 +509,7 @@ 2 -> do len <- getWord32be bs <- getLazyByteString (fromIntegral len) return (t, bs)- 3 -> do len <- remaining- bs <- getLazyByteString len+ 3 -> do bs <- getRemainingLazyByteString return (t, bs) _ -> error "This should never happen (getPacketTypeAndPayload/0x00)." 0x40 -> do@@ -533,15 +530,13 @@ | t == 1 = do pv <- getWord8 eokeyid <- getLazyByteString 8- pkalgo <- getWord8- remainder <- remaining- mpib <- getLazyByteString remainder+ pka <- getWord8+ mpib <- getRemainingLazyByteString case runGetOrFail (some getMPI) mpib of Left (_, _, e) -> fail ("PKESK MPIs " ++ e)- Right (_, _, sk) -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pkalgo) (NE.fromList sk)+ Right (_, _, sk) -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk) | t == 2 = do- remainder <- remaining- bs <- getLazyByteString remainder+ bs <- getRemainingLazyByteString case runGetOrFail get bs of Left (_, _, e) -> fail ("signature packet " ++ e) Right (_, _, sp) -> return $ SignaturePkt sp@@ -549,8 +544,7 @@ pv <- getWord8 symalgo <- getWord8 s2k <- getS2K- remainder <- remaining- esk <- getLazyByteString remainder+ esk <- getRemainingLazyByteString return $ SKESKPkt pv (toFVal symalgo) s2k (if BL.null esk then Nothing else Just esk) | t == 4 = do pv <- getWord8@@ -630,7 +624,7 @@ getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket getUserAttrSubPacket' t l | t == 1 = do- ihlen <- getWord16le+ _ <- getWord16le -- ihlen hver <- getWord8 -- should be 1 iformat <- getWord8 nuls <- getLazyByteString 12 -- should be NULs@@ -658,19 +652,18 @@ putLazyByteString bs putPkt :: Pkt -> Put-putPkt (PKESKPkt pv eokeyid pkalgo mpis) = do+putPkt (PKESKPkt pv eokeyid pka mpis) = do putWord8 (0xc0 .|. 1) let bsk = runPut $ F.mapM_ put mpis putPacketLength . fromIntegral $ 10 + BL.length bsk putWord8 pv -- must be 3 putLazyByteString (unEOKI eokeyid) -- must be 8 octets- putWord8 $ fromIntegral . fromFVal $ pkalgo+ putWord8 $ fromIntegral . fromFVal $ pka putLazyByteString bsk putPkt (SignaturePkt sp) = do putWord8 (0xc0 .|. 2) let bs = runPut $ put sp- putPacketLength . fromIntegral . BL.length $ bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (SKESKPkt pv symalgo s2k mesk) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k@@ -689,38 +682,31 @@ putWord8 $ fromIntegral . fromFVal $ pka putLazyByteString (unEOKI skeyid) putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean?- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (SecretKeyPkt pkp ska) = do putWord8 (0xc0 .|. 5) let bs = runPut (putPKPayload pkp >> putSKAddendum ska)- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (PublicKeyPkt pkp) = do putWord8 (0xc0 .|. 6) let bs = runPut $ putPKPayload pkp- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (SecretSubkeyPkt pkp ska) = do putWord8 (0xc0 .|. 7) let bs = runPut (putPKPayload pkp >> putSKAddendum ska)- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (CompressedDataPkt ca cdata) = do putWord8 (0xc0 .|. 8) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ ca putLazyByteString cdata- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (SymEncDataPkt b) = do putWord8 (0xc0 .|. 9)- putPacketLength . fromIntegral $ BL.length b- putLazyByteString b+ putLengthThenPayload b putPkt (MarkerPkt b) = do putWord8 (0xc0 .|. 10)- putPacketLength . fromIntegral $ BL.length b- putLazyByteString b+ putLengthThenPayload b putPkt (LiteralDataPkt dt fn ts b) = do putWord8 (0xc0 .|. 11) let bs = runPut $ do@@ -729,12 +715,10 @@ putLazyByteString fn putWord32be . unThirtyTwoBitTimeStamp $ ts putLazyByteString b- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (TrustPkt b) = do putWord8 (0xc0 .|. 12)- putPacketLength . fromIntegral . BL.length $ b- putLazyByteString b+ putLengthThenPayload b putPkt (UserIdPkt u) = do putWord8 (0xc0 .|. 13) let bs = encodeUtf8 u@@ -743,13 +727,11 @@ putPkt (PublicSubkeyPkt pkp) = do putWord8 (0xc0 .|. 14) let bs = runPut $ putPKPayload pkp- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (UserAttributePkt us) = do putWord8 (0xc0 .|. 17) let bs = runPut $ mapM_ put us- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs+ putLengthThenPayload bs putPkt (SymEncIntegrityProtectedDataPkt pv b) = do putWord8 (0xc0 .|. 18) putPacketLength . fromIntegral $ BL.length b + 1@@ -757,14 +739,17 @@ putLazyByteString b putPkt (ModificationDetectionCodePkt hash) = do putWord8 (0xc0 .|. 19)- putPacketLength . fromIntegral . BL.length $ hash- putLazyByteString hash+ putLengthThenPayload hash putPkt (OtherPacketPkt t payload) = do putWord8 (0xc0 .|. t) -- FIXME: restrict t- putPacketLength . fromIntegral . BL.length $ payload- putLazyByteString payload+ putLengthThenPayload payload putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) +putLengthThenPayload :: ByteString -> Put+putLengthThenPayload bs = do+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs+ getMPI :: Get MPI getMPI = do mpilen <- getWord16be bs <- getLazyByteString (fromIntegral (mpilen + 7) `div` 8)@@ -786,7 +771,7 @@ MPI g <- get MPI y <- get return $ ElGamalPubKey [p,g,y]-getPubkey _ = UnknownPKey <$> (getLazyByteString =<< remaining)+getPubkey _ = UnknownPKey <$> getRemainingLazyByteString putPubkey :: PKey -> Put putPubkey (UnknownPKey bs) = put bs@@ -799,8 +784,7 @@ MPI p <- get MPI q <- get MPI _ <- get -- u- let n = p * q- dP = 0+ let dP = 0 dQ = 0 qinv = 0 pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp^.pubkey)@@ -861,8 +845,7 @@ OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty _ -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc)- remainder <- remaining- encryptedblock <- getLazyByteString remainder+ encryptedblock <- getRemainingLazyByteString return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock 254 -> do symenc <- getWord8 s2k <- getS2K@@ -870,12 +853,10 @@ OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty _ -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc)- remainder <- remaining- encryptedblock <- getLazyByteString remainder+ encryptedblock <- getRemainingLazyByteString return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc)- remainder <- remaining- encryptedblock <- getLazyByteString remainder+ encryptedblock <- getRemainingLazyByteString return $ SUSym (toFVal symenc) (IV iv) encryptedblock putSKAddendum :: SKAddendum -> Put@@ -1178,8 +1159,7 @@ pka <- get ha <- get left16 <- getWord16be- remainder <- remaining- mpib <- getLazyByteString remainder+ mpib <- getRemainingLazyByteString case runGetOrFail (some getMPI) mpib of Left (_, _, e) -> fail ("v3 sig MPIs " ++ e) Right (_, _, mpis) -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 (NE.fromList mpis)@@ -1198,14 +1178,12 @@ Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err) Right (_, _, u) -> u left16 <- getWord16be- remainder <- remaining- mpib <- getLazyByteString remainder+ mpib <- getRemainingLazyByteString case runGetOrFail (some getMPI) mpib of Left (_, _, e) -> fail ("v4 sig MPIs " ++ e) Right (_, _, mpis) -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 (NE.fromList mpis) _ -> do- remainder <- remaining- bs <- getLazyByteString remainder+ bs <- getRemainingLazyByteString return $ SigVOther pv bs putSignaturePayload :: SignaturePayload -> Put
Codec/Encryption/OpenPGP/Types.hs view
@@ -15,8 +15,10 @@ import GHC.Generics (Generic) +import Control.Applicative ((<$>), (<|>)) import Control.Arrow ((***)) import Control.Lens (makeLenses)+import Control.Monad (mzero) import Control.Newtype (Newtype(..)) import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA@@ -35,6 +37,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.List.Split (chunksOf)+import Data.Maybe (fromMaybe) import Data.Monoid ((<>), Monoid, mempty) import Data.Ord (comparing) import Data.Set (Set)@@ -45,7 +48,7 @@ import Data.Time.Format (formatTime) import Data.Typeable (Typeable) import Data.Word (Word8, Word16, Word32)-import Network.URI (URI(..), uriToString)+import Network.URI (URI(..), uriToString, nullURI, parseURI) import Numeric (readHex, showHex) import System.Locale (defaultTimeLocale) import Text.PrettyPrint.Free (Pretty(..), (<+>), char, hsep, punctuate, space, text, tupled)@@ -57,8 +60,6 @@ type Revocability = Bool type RevocationReason = Text type KeyServer = ByteString-type NotationName = ByteString-type NotationValue = ByteString type SignatureHash = ByteString type PacketVersion = Word8 type V3Expiration = Word16@@ -85,7 +86,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord SymmetricAlgorithm where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal SymmetricAlgorithm where fromFVal Plaintext = 0@@ -130,6 +131,7 @@ pretty (OtherSA sa) = text "unknown symmetric algorithm" <+> (text . show) sa instance A.ToJSON SymmetricAlgorithm+instance A.FromJSON SymmetricAlgorithm data NotationFlag = HumanReadable | OtherNF Word8 -- FIXME: this should be constrained to 4 bits?@@ -139,7 +141,7 @@ (==) a b = fromFFlag a == fromFFlag b instance Ord NotationFlag where- compare a b = fromFFlag a `compare` fromFFlag b+ compare = comparing fromFFlag instance FutureFlag NotationFlag where fromFFlag HumanReadable = 0@@ -155,6 +157,7 @@ pretty (OtherNF o) = text "unknown notation flag type" <+> pretty o instance A.ToJSON NotationFlag+instance A.FromJSON NotationFlag data SigSubPacket = SigSubPacket { _sspCriticality :: Bool@@ -167,6 +170,7 @@ instance Hashable SigSubPacket instance A.ToJSON SigSubPacket+instance A.FromJSON SigSubPacket newtype ThirtyTwoBitTimeStamp = ThirtyTwoBitTimeStamp {unThirtyTwoBitTimeStamp :: Word32} deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable)@@ -179,6 +183,7 @@ pretty = text . formatTime defaultTimeLocale "%Y%m%d-%H%M%S" . posixSecondsToUTCTime . realToFrac instance A.ToJSON ThirtyTwoBitTimeStamp+instance A.FromJSON ThirtyTwoBitTimeStamp newtype ThirtyTwoBitDuration = ThirtyTwoBitDuration {unThirtyTwoBitDuration :: Word32} deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable)@@ -191,6 +196,7 @@ pretty = text . concat . unfoldr durU . unpack instance A.ToJSON ThirtyTwoBitDuration+instance A.FromJSON ThirtyTwoBitDuration durU :: (Integral a, Show a) => a -> Maybe (String, a) durU x@@ -214,8 +220,40 @@ pretty = pretty . (\uri -> uriToString id uri "") . unpack instance A.ToJSON URL where- toJSON = A.toJSON . (\uri -> uriToString id uri "") . unpack+ toJSON u = object [T.pack "uri" .= (\uri -> uriToString id uri "") (unpack u)]+instance A.FromJSON URL where+ parseJSON (A.Object v) = URL . fromMaybe nullURI . parseURI <$>+ v A..: T.pack "uri"+ parseJSON _ = mzero +newtype NotationName = NotationName {unNotationName :: ByteString}+ deriving (Data, Eq, Generic, Hashable, Ord, Pretty, Show, Typeable)++instance Newtype NotationName ByteString where+ pack = NotationName+ unpack (NotationName nn) = nn++instance A.ToJSON NotationName where+ toJSON nn = object [T.pack "notationname" .= show (unpack nn)]+instance A.FromJSON NotationName where+ parseJSON (A.Object v) = NotationName . read <$>+ v A..: T.pack "notationname"+ parseJSON _ = mzero++newtype NotationValue = NotationValue {unNotationValue :: ByteString}+ deriving (Data, Eq, Generic, Hashable, Ord, Pretty, Show, Typeable)++instance Newtype NotationValue ByteString where+ pack = NotationValue+ unpack (NotationValue nv) = nv++instance A.ToJSON NotationValue where+ toJSON nv = object [T.pack "notationvalue" .= show (unpack nv)]+instance A.FromJSON NotationValue where+ parseJSON (A.Object v) = NotationValue . read <$>+ v A..: T.pack "notationvalue"+ parseJSON _ = mzero+ data SigSubPacketPayload = SigCreationTime ThirtyTwoBitTimeStamp | SigExpirationTime ThirtyTwoBitDuration | ExportableCertification Exportability@@ -273,32 +311,49 @@ pretty (OtherSigSub t bs) = text "unknown signature subpacket type" <+> pretty t <+> pretty bs instance A.ToJSON SigSubPacketPayload where- toJSON (SigCreationTime ts) = A.toJSON ts- toJSON (SigExpirationTime d) = A.toJSON d- toJSON (ExportableCertification e) = A.toJSON e- toJSON (TrustSignature tl ta) = A.toJSON (tl, ta)- toJSON (RegularExpression apdre) = A.toJSON (BL.unpack apdre)- toJSON (Revocable r) = A.toJSON r- toJSON (KeyExpirationTime d) = A.toJSON d- toJSON (PreferredSymmetricAlgorithms sas) = A.toJSON sas- toJSON (RevocationKey rcs pka tof) = A.toJSON (rcs, pka, tof)- toJSON (Issuer eoki) = A.toJSON eoki- toJSON (NotationData nfs nn nv) = A.toJSON (nfs, BL.unpack nn, BL.unpack nv)- toJSON (PreferredHashAlgorithms phas) = A.toJSON phas- toJSON (PreferredCompressionAlgorithms pcas) = A.toJSON pcas- toJSON (KeyServerPreferences kspfs) = A.toJSON kspfs- toJSON (PreferredKeyServer ks) = A.toJSON (show ks)- toJSON (PrimaryUserId p) = A.toJSON p- toJSON (PolicyURL u) = A.toJSON u- toJSON (KeyFlags kfs) = A.toJSON kfs- toJSON (SignersUserId u) = A.toJSON u- toJSON (ReasonForRevocation rc rr) = A.toJSON (rc, rr)- toJSON (Features ffs) = A.toJSON ffs- toJSON (SignatureTarget pka ha sh) = A.toJSON (pka, ha, BL.unpack sh)- toJSON (EmbeddedSignature sp) = A.toJSON sp- toJSON (UserDefinedSigSub t bs) = A.toJSON (t, BL.unpack bs)- toJSON (OtherSigSub t bs) = A.toJSON (t, BL.unpack bs)+ toJSON (SigCreationTime ts) = object [T.pack "sigCreationTime" .= ts]+ toJSON (SigExpirationTime d) = object [T.pack "sigExpirationTime" .= d]+ toJSON (ExportableCertification e) = object [T.pack "exportableCertification" .= e]+ toJSON (TrustSignature tl ta) = object [T.pack "trustSignature" .= (tl, ta)]+ toJSON (RegularExpression apdre) = object [T.pack "regularExpression" .= (BL.unpack apdre)]+ toJSON (Revocable r) = object [T.pack "revocable" .= r]+ toJSON (KeyExpirationTime d) = object [T.pack "keyExpirationTime" .= d]+ toJSON (PreferredSymmetricAlgorithms sas) = object [T.pack "preferredSymmetricAlgorithms" .= sas]+ toJSON (RevocationKey rcs pka tof) = object [T.pack "revocationKey" .= (rcs, pka, tof)]+ toJSON (Issuer eoki) = object [T.pack "issuer" .= eoki]+ toJSON (NotationData nfs (NotationName nn) (NotationValue nv)) = object [T.pack "notationData" .= (nfs, BL.unpack nn, BL.unpack nv)]+ toJSON (PreferredHashAlgorithms phas) = object [T.pack "preferredHashAlgorithms" .= phas]+ toJSON (PreferredCompressionAlgorithms pcas) = object [T.pack "preferredCompressionAlgorithms" .= pcas]+ toJSON (KeyServerPreferences kspfs) = object [T.pack "keyServerPreferences" .= kspfs]+ toJSON (PreferredKeyServer ks) = object [T.pack "preferredKeyServer" .= (show ks)]+ toJSON (PrimaryUserId p) = object [T.pack "primaryUserId" .= p]+ toJSON (PolicyURL u) = object [T.pack "policyURL" .= u]+ toJSON (KeyFlags kfs) = object [T.pack "keyFlags" .= kfs]+ toJSON (SignersUserId u) = object [T.pack "signersUserId" .= u]+ toJSON (ReasonForRevocation rc rr) = object [T.pack "reasonForRevocation" .= (rc, rr)]+ toJSON (Features ffs) = object [T.pack "features" .= ffs]+ toJSON (SignatureTarget pka ha sh) = object [T.pack "signatureTarget" .= (pka, ha, BL.unpack sh)]+ toJSON (EmbeddedSignature sp) = object [T.pack "embeddedSignature" .= sp]+ toJSON (UserDefinedSigSub t bs) = object [T.pack "userDefinedSigSub" .= (t, BL.unpack bs)]+ toJSON (OtherSigSub t bs) = object [T.pack "otherSigSub" .= (t, BL.unpack bs)] +instance A.FromJSON SigSubPacketPayload where+ parseJSON (A.Object v) = (SigCreationTime <$> v A..: T.pack "sigCreationTime")+ <|> (SigExpirationTime <$> v A..: T.pack "sigExpirationTime")+ <|> (ExportableCertification <$> v A..: T.pack "exportableCertification")+ <|> (uncurry TrustSignature <$> v A..: T.pack "trustSignature")+ <|> (RegularExpression . BL.pack <$> v A..: T.pack "regularExpression")+ <|> (Revocable <$> v A..: T.pack "revocable")+ <|> (KeyExpirationTime <$> v A..: T.pack "keyExpirationTime")+ <|> (PreferredSymmetricAlgorithms <$> v A..: T.pack "preferredSymmetricAlgorithms")+ <|> (uc3 RevocationKey <$> v A..: T.pack "revocationKey")+ <|> (Issuer <$> v A..: T.pack "issuer")+ <|> (uc3 NotationData <$> v A..: T.pack "notationData")+ parseJSON _ = mzero++uc3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)+uc3 f ~(a,b,c) = f a b c+ data HashAlgorithm = DeprecatedMD5 | SHA1 | RIPEMD160@@ -313,7 +368,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord HashAlgorithm where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal HashAlgorithm where fromFVal DeprecatedMD5 = 1@@ -346,6 +401,7 @@ pretty (OtherHA ha) = text "unknown hash algorithm type" <+> (text . show) ha instance A.ToJSON HashAlgorithm+instance A.FromJSON HashAlgorithm data CompressionAlgorithm = Uncompressed | ZIP@@ -358,7 +414,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord CompressionAlgorithm where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal CompressionAlgorithm where fromFVal Uncompressed = 0@@ -382,6 +438,7 @@ pretty (OtherCA ca) = text "unknown compression algorithm type" <+> (text . show) ca instance A.ToJSON CompressionAlgorithm+instance A.FromJSON CompressionAlgorithm class (Eq a, Ord a) => FutureVal a where fromFVal :: a -> Word8@@ -403,7 +460,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord PubKeyAlgorithm where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal PubKeyAlgorithm where fromFVal RSA = 1@@ -442,6 +499,7 @@ pretty pka = text "unknown pubkey algorithm type" <+> (text . show) pka instance A.ToJSON PubKeyAlgorithm+instance A.FromJSON PubKeyAlgorithm class (Eq a, Ord a) => FutureFlag a where fromFFlag :: a -> Int@@ -455,7 +513,7 @@ (==) a b = fromFFlag a == fromFFlag b instance Ord KSPFlag where- compare a b = fromFFlag a `compare` fromFFlag b+ compare = comparing fromFFlag instance FutureFlag KSPFlag where fromFFlag NoModify = 0@@ -471,6 +529,7 @@ pretty (KSPOther o) = text "unknown keyserver preference flag type" <+> pretty o instance A.ToJSON KSPFlag+instance A.FromJSON KSPFlag data KeyFlag = GroupKey | AuthKey@@ -486,7 +545,7 @@ (==) a b = fromFFlag a == fromFFlag b instance Ord KeyFlag where- compare a b = fromFFlag a `compare` fromFFlag b+ compare = comparing fromFFlag instance FutureFlag KeyFlag where fromFFlag GroupKey = 0@@ -520,6 +579,7 @@ pretty (KFOther o) = text "unknown key flag type" <+> pretty o instance A.ToJSON KeyFlag+instance A.FromJSON KeyFlag data RevocationClass = SensitiveRK | RClOther Word8 -- FIXME: this should be constrained to 3 bits@@ -529,7 +589,7 @@ (==) a b = fromFFlag a == fromFFlag b instance Ord RevocationClass where- compare a b = fromFFlag a `compare` fromFFlag b+ compare = comparing fromFFlag instance FutureFlag RevocationClass where fromFFlag SensitiveRK = 1@@ -545,6 +605,7 @@ pretty (RClOther o) = text "unknown revocation class" <+> pretty o instance A.ToJSON RevocationClass+instance A.FromJSON RevocationClass data RevocationCode = NoReason | KeySuperseded@@ -558,7 +619,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord RevocationCode where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal RevocationCode where fromFVal NoReason = 0@@ -585,6 +646,7 @@ pretty (RCoOther o) = text "unknown revocation code" <+> pretty o instance A.ToJSON RevocationCode+instance A.FromJSON RevocationCode data FeatureFlag = ModificationDetection | FeatureOther Int@@ -594,7 +656,7 @@ (==) a b = fromFFlag a == fromFFlag b instance Ord FeatureFlag where- compare a b = fromFFlag a `compare` fromFFlag b+ compare = comparing fromFFlag instance FutureFlag FeatureFlag where fromFFlag ModificationDetection = 7@@ -612,6 +674,7 @@ pretty (FeatureOther o) = text "unknown feature flag type" <+> pretty o instance A.ToJSON FeatureFlag+instance A.FromJSON FeatureFlag newtype MPI = MPI {unMPI :: Integer} deriving (Data, Eq, Generic, Show, Typeable)@@ -626,6 +689,7 @@ pretty = pretty . unpack instance A.ToJSON MPI+instance A.FromJSON MPI data SignaturePayload = SigV3 SigType ThirtyTwoBitTimeStamp EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 (NonEmpty MPI) | SigV4 SigType PubKeyAlgorithm HashAlgorithm [SigSubPacket] [SigSubPacket] Word16 (NonEmpty MPI)@@ -654,6 +718,7 @@ pretty V4 = text "v4" instance A.ToJSON KeyVersion+instance A.FromJSON KeyVersion data PKPayload = PKPayload { _keyVersion :: KeyVersion@@ -664,7 +729,7 @@ } deriving (Data, Eq, Generic, Show, Typeable) instance Ord PKPayload where- compare = comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> comparing _pkalgo <> comparing (show . _pubkey) -- FIXME: this is suboptimal+ compare = comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> comparing _pkalgo <> comparing _pubkey instance Hashable PKPayload @@ -721,7 +786,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord DataType where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal DataType where fromFVal BinaryData = fromIntegral . fromEnum $ 'b'@@ -741,6 +806,7 @@ pretty (OtherData o) = text "other data type " <+> (text . show) o instance A.ToJSON DataType+instance A.FromJSON DataType newtype Salt = Salt {unSalt :: B.ByteString} deriving (Byteable, Data, Eq, Generic, Hashable, Show, Typeable)@@ -766,6 +832,7 @@ pretty = pretty . unpack instance A.ToJSON IterationCount+instance A.FromJSON IterationCount data S2K = Simple HashAlgorithm | Salted HashAlgorithm Salt@@ -819,6 +886,7 @@ pretty (ImageHV1 f) = text "imghdr v1" <+> pretty f instance A.ToJSON ImageHeader+instance A.FromJSON ImageHeader data ImageFormat = JPEG | OtherImage Word8@@ -828,7 +896,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord ImageFormat where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal ImageFormat where fromFVal JPEG = 1@@ -844,6 +912,7 @@ pretty (OtherImage o) = text "unknown image format" <+> pretty o instance A.ToJSON ImageFormat+instance A.FromJSON ImageFormat data SigType = BinarySig | CanonicalTextSig@@ -867,7 +936,7 @@ (==) a b = fromFVal a == fromFVal b instance Ord SigType where- compare a b = fromFVal a `compare` fromFVal b+ compare = comparing fromFVal instance FutureVal SigType where fromFVal BinarySig = 0x00@@ -925,6 +994,7 @@ pretty (OtherSig o) = text "unknown signature type" <+> pretty o instance A.ToJSON SigType+instance A.FromJSON SigType newtype DSA_PublicKey = DSA_PublicKey {unDSA_PublicKey :: DSA.PublicKey} deriving (Data, Eq, Generic, Show, Typeable)@@ -1069,8 +1139,13 @@ instance Hashable EightOctetKeyId instance A.ToJSON EightOctetKeyId where- toJSON = A.toJSON . w8sToHex . BL.unpack . unpack+ toJSON e = object [T.pack "eoki" .= (w8sToHex . BL.unpack . unpack) e] +instance A.FromJSON EightOctetKeyId where+ parseJSON (A.Object v) = EightOctetKeyId . read <$>+ v A..: T.pack "eoki"+ parseJSON _ = mzero+ newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString} deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -1088,7 +1163,11 @@ pretty = text . take 40 . w8sToHex . BL.unpack . unTOF instance A.ToJSON TwentyOctetFingerprint where- toJSON = A.toJSON . show . pretty+ toJSON e = object [T.pack "fpr" .= (A.toJSON . show . pretty) e]+instance A.FromJSON TwentyOctetFingerprint where+ parseJSON (A.Object v) = TwentyOctetFingerprint . read <$>+ v A..: T.pack "fpr"+ parseJSON _ = mzero newtype SpacedFingerprint = SpacedFingerprint { unSpacedFingerprint :: TwentyOctetFingerprint } @@ -1111,11 +1190,13 @@ , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkSubs :: [(Pkt, [SignaturePayload])]- } deriving (Data, Eq, Show, Typeable)+ } deriving (Data, Eq, Generic, Show, Typeable) instance Ord TK where compare = comparing _tkKey -- FIXME: is this ridiculous? +instance A.ToJSON TK+ type Keyring = IxSet TK class Packet a where@@ -1218,7 +1299,7 @@ { _pkeskPacketVersion :: PacketVersion , _pkeskEightOctetKeyId :: EightOctetKeyId , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm- , _pkeskMPIs :: (NonEmpty MPI)+ , _pkeskMPIs :: NonEmpty MPI } deriving (Data, Eq, Show, Typeable) instance Packet PKESK where data PacketType PKESK = PKESKType deriving (Show, Eq)@@ -1226,6 +1307,7 @@ packetCode _ = 1 toPkt (PKESK a b c d) = PKESKPkt a b c d fromPkt (PKESKPkt a b c d) = PKESK a b c d+ fromPkt _ = error "Cannot coerce non-PKESK packet" instance Pretty PKESK where pretty = pretty . toPkt@@ -1237,8 +1319,9 @@ data PacketType Signature = SignatureType deriving (Show, Eq) packetType _ = SignatureType packetCode _ = 2- toPkt (Signature a ) = SignaturePkt a+ toPkt (Signature a) = SignaturePkt a fromPkt (SignaturePkt a) = Signature a+ fromPkt _ = error "Cannot coerce non-Signature packet" instance Pretty Signature where pretty = pretty . toPkt@@ -1255,6 +1338,7 @@ packetCode _ = 3 toPkt (SKESK a b c d) = SKESKPkt a b c d fromPkt (SKESKPkt a b c d) = SKESK a b c d+ fromPkt _ = error "Cannot coerce non-SKESK packet" instance Pretty SKESK where pretty = pretty . toPkt@@ -1273,6 +1357,7 @@ packetCode _ = 4 toPkt (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f+ fromPkt _ = error "Cannot coerce non-OnePassSignature packet" instance Pretty OnePassSignature where pretty = pretty . toPkt@@ -1287,6 +1372,7 @@ packetCode _ = 5 toPkt (SecretKey a b) = SecretKeyPkt a b fromPkt (SecretKeyPkt a b) = SecretKey a b+ fromPkt _ = error "Cannot coerce non-SecretKey packet" instance Pretty SecretKey where pretty = pretty . toPkt@@ -1300,6 +1386,7 @@ packetCode _ = 6 toPkt (PublicKey a) = PublicKeyPkt a fromPkt (PublicKeyPkt a) = PublicKey a+ fromPkt _ = error "Cannot coerce non-PublicKey packet" instance Pretty PublicKey where pretty = pretty . toPkt@@ -1314,6 +1401,7 @@ packetCode _ = 7 toPkt (SecretSubkey a b) = SecretSubkeyPkt a b fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b+ fromPkt _ = error "Cannot coerce non-SecretSubkey packet" instance Pretty SecretSubkey where pretty = pretty . toPkt@@ -1328,6 +1416,7 @@ packetCode _ = 8 toPkt (CompressedData a b) = CompressedDataPkt a b fromPkt (CompressedDataPkt a b) = CompressedData a b+ fromPkt _ = error "Cannot coerce non-CompressedData packet" instance Pretty CompressedData where pretty = pretty . toPkt@@ -1341,6 +1430,7 @@ packetCode _ = 9 toPkt (SymEncData a) = SymEncDataPkt a fromPkt (SymEncDataPkt a) = SymEncData a+ fromPkt _ = error "Cannot coerce non-SymEncData packet" instance Pretty SymEncData where pretty = pretty . toPkt@@ -1354,6 +1444,7 @@ packetCode _ = 10 toPkt (Marker a) = MarkerPkt a fromPkt (MarkerPkt a) = Marker a+ fromPkt _ = error "Cannot coerce non-Marker packet" instance Pretty Marker where pretty = pretty . toPkt@@ -1370,6 +1461,7 @@ packetCode _ = 11 toPkt (LiteralData a b c d) = LiteralDataPkt a b c d fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d+ fromPkt _ = error "Cannot coerce non-LiteralData packet" instance Pretty LiteralData where pretty = pretty . toPkt@@ -1383,6 +1475,7 @@ packetCode _ = 12 toPkt (Trust a) = TrustPkt a fromPkt (TrustPkt a) = Trust a+ fromPkt _ = error "Cannot coerce non-Trust packet" instance Pretty Trust where pretty = pretty . toPkt@@ -1396,6 +1489,7 @@ packetCode _ = 13 toPkt (UserId a) = UserIdPkt a fromPkt (UserIdPkt a) = UserId a+ fromPkt _ = error "Cannot coerce non-UserId packet" instance Pretty UserId where pretty = pretty . toPkt@@ -1409,6 +1503,7 @@ packetCode _ = 14 toPkt (PublicSubkey a) = PublicSubkeyPkt a fromPkt (PublicSubkeyPkt a) = PublicSubkey a+ fromPkt _ = error "Cannot coerce non-PublicSubkey packet" instance Pretty PublicSubkey where pretty = pretty . toPkt@@ -1422,6 +1517,7 @@ packetCode _ = 17 toPkt (UserAttribute a) = UserAttributePkt a fromPkt (UserAttributePkt a) = UserAttribute a+ fromPkt _ = error "Cannot coerce non-UserAttribute packet" instance Pretty UserAttribute where pretty = pretty . toPkt@@ -1436,6 +1532,7 @@ packetCode _ = 18 toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b fromPkt (SymEncIntegrityProtectedDataPkt a b) = SymEncIntegrityProtectedData a b+ fromPkt _ = error "Cannot coerce non-SymEncIntegrityProtectedData packet" instance Pretty SymEncIntegrityProtectedData where pretty = pretty . toPkt@@ -1449,6 +1546,7 @@ packetCode _ = 19 toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a+ fromPkt _ = error "Cannot coerce non-ModificationDetectionCode packet" instance Pretty ModificationDetectionCode where pretty = pretty . toPkt@@ -1463,6 +1561,7 @@ packetCode _ = undefined -- FIXME toPkt (OtherPacket a b) = OtherPacketPkt a b fromPkt (OtherPacketPkt a b) = OtherPacket a b+ fromPkt _ = error "Cannot coerce non-OtherPacket packet" instance Pretty OtherPacket where pretty = pretty . toPkt@@ -1478,6 +1577,7 @@ packetCode _ = undefined toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c+ fromPkt _ = error "Cannot coerce non-BrokenPacket packet" instance Pretty BrokenPacket where pretty = pretty . toPkt
hOpenPGP.cabal view
@@ -1,5 +1,5 @@ Name: hOpenPGP-Version: 2.0+Version: 2.1 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/@@ -328,4 +328,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git- tag: v1.11+ tag: v2.1
tests/suite.hs view
@@ -117,7 +117,7 @@ testKeysExpiration expectsuccess keyfile = do ks <- runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume let Right verifieds = mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks- tvalid = all (isTKTimeValid (posixSecondsToUTCTime (realToFrac 1400000000))) verifieds+ tvalid = all (isTKTimeValid (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer)))) verifieds assertEqual (keyfile ++ " key expiration") expectsuccess tvalid -- This needs a lot of work