diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -110,7 +110,21 @@ arbitrary = elements [DeprecatedMD5, SHA1, RIPEMD160, SHA256, SHA384, SHA512, SHA224] instance Arbitrary SymmetricAlgorithm where - arbitrary = elements [Plaintext, IDEA, TripleDES, CAST5, Blowfish, ReservedSAFER, ReservedDES, AES128, AES192, AES256, Twofish] + arbitrary = elements [Plaintext + , IDEA + , TripleDES + , CAST5 + , Blowfish + , ReservedSAFER + , ReservedDES + , AES128 + , AES192 + , AES256 + , Twofish + , Camellia128 + , Camellia192 + , Camellia256 + ] instance Arbitrary RevocationClass where arbitrary = frequency [(9,srk),(1,rco)] diff --git a/Codec/Encryption/OpenPGP/BlockCipher.hs b/Codec/Encryption/OpenPGP/BlockCipher.hs --- a/Codec/Encryption/OpenPGP/BlockCipher.hs +++ b/Codec/Encryption/OpenPGP/BlockCipher.hs @@ -10,7 +10,6 @@ , withSymmetricCipher ) where -import Codec.Encryption.OpenPGP.Internal import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (HOWrappedOldCCT(..)) import Codec.Encryption.OpenPGP.Internal.Cryptonite (HOWrappedCCT(..)) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher @@ -19,6 +18,7 @@ import qualified Crypto.Cipher.Blowfish as Blowfish import qualified Crypto.Cipher.TripleDES as TripleDES import qualified Crypto.Cipher.AES as AES +import qualified Crypto.Cipher.Camellia as Camellia import qualified Crypto.Nettle.Ciphers as CNC import qualified Data.ByteString as B @@ -37,6 +37,9 @@ withSymmetricCipher AES128 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES128)) >>= f withSymmetricCipher AES192 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES192)) >>= f withSymmetricCipher AES256 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES256)) >>= f +withSymmetricCipher Camellia128 key f = (cipherInit key :: Either String (HOWrappedCCT Camellia.Camellia128)) >>= f +withSymmetricCipher Camellia192 key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia192)) >>= f +withSymmetricCipher Camellia256 key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia256)) >>= f -- in octets; FIXME: co-opt Cipher's cipherKeySize or not? keySize :: SymmetricAlgorithm -> Int @@ -51,4 +54,7 @@ keySize AES192 = 24 keySize AES256 = 32 keySize Twofish = 32 +keySize Camellia128 = 16 +keySize Camellia192 = 24 +keySize Camellia256 = 32 keySize (OtherSA _) = undefined diff --git a/Codec/Encryption/OpenPGP/CFB.hs b/Codec/Encryption/OpenPGP/CFB.hs --- a/Codec/Encryption/OpenPGP/CFB.hs +++ b/Codec/Encryption/OpenPGP/CFB.hs @@ -4,6 +4,8 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE CPP #-} + module Codec.Encryption.OpenPGP.CFB ( decrypt , decryptNoNonce @@ -12,18 +14,12 @@ ) where import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher) -import Codec.Encryption.OpenPGP.Internal -import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes -import Codec.Encryption.OpenPGP.Internal.Cryptonite import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) -import Control.Error.Util (note) -import qualified Crypto.Cipher.AES as CCA -import qualified Crypto.Cipher.Blowfish as CCB -import qualified Crypto.Cipher.TripleDES as CC3 -import qualified Crypto.Nettle.Ciphers as CNC -import Data.ByteArray (ByteArray) +#endif +import Control.Monad (liftM) import qualified Data.ByteString as B decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString @@ -36,12 +32,12 @@ decrypt1 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt1 ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) (B.take (blockSize cipher + 2) ct) decrypt2 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString - decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in (paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct)) + decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct) decrypt :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString decrypt Plaintext ciphertext _ = return ciphertext decrypt sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do - (nonce, cleartext) <- decrypt' ciphertext bc >>= return . (B.splitAt (blockSize bc + 2)) + (nonce, cleartext) <- liftM (B.splitAt (blockSize bc + 2)) (decrypt' ciphertext bc) if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed" where decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString @@ -49,8 +45,7 @@ decryptNoNonce :: SymmetricAlgorithm -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext -decryptNoNonce sa iv ciphertext keydata = do - withSymmetricCipher sa keydata (decrypt' ciphertext) +decryptNoNonce sa iv ciphertext keydata = withSymmetricCipher sa keydata (decrypt' ciphertext) where decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct @@ -59,9 +54,8 @@ nonceCheck bc = (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc) encryptNoNonce :: SymmetricAlgorithm -> S2K -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString -encryptNoNonce Plaintext _ _ payload keydata = return payload -encryptNoNonce sa s2k iv payload keydata = do - withSymmetricCipher sa keydata (encrypt' payload) +encryptNoNonce Plaintext _ _ payload _ = return payload +encryptNoNonce sa s2k iv payload keydata = withSymmetricCipher sa keydata (encrypt' payload) where encrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -117,6 +117,6 @@ w = fromJust $ inverse s q u1 = (hm*w) `mod` q u2 = (r*w) `mod` q - v = ((expFast g u1 p) * (expFast y u2 p)) `mod` p `mod` q + v = (expFast g u1 p * expFast y u2 p) `mod` p `mod` q dsaTruncate bs = let lbs = BL.fromStrict bs in if countBits lbs > fromIntegral dsaQLen then B.take (dsaQLen `div` 8) bs else bs -- FIXME: uneven bits - dsaQLen = numBits $ q + dsaQLen = numBits q diff --git a/Codec/Encryption/OpenPGP/KeySelection.hs b/Codec/Encryption/OpenPGP/KeySelection.hs --- a/Codec/Encryption/OpenPGP/KeySelection.hs +++ b/Codec/Encryption/OpenPGP/KeySelection.hs @@ -1,8 +1,9 @@ -- KeySelection.hs: OpenPGP (RFC4880) ways to ask for keys --- Copyright © 2014-2015 Clint Adams +-- Copyright © 2014-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.KeySelection ( @@ -11,7 +12,10 @@ ) where import Codec.Encryption.OpenPGP.Types -import Control.Applicative (optional, (<$>), (*>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (*>)) +#endif +import Control.Applicative (optional) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text (asciiCI, count, hexadecimal, inClass, parseOnly, Parser, satisfy) diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -1,8 +1,10 @@ -- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing --- Copyright © 2012-2015 Clint Adams +-- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE CPP #-} + module Codec.Encryption.OpenPGP.KeyringParser ( parseAChunk , finalizeParsing @@ -24,8 +26,16 @@ , broken ) where -import Control.Applicative (many, (<$>), (<|>)) -import Data.Monoid (Monoid, (<>), mconcat) +import Control.Applicative (many, (<|>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid, mconcat) +#endif +import Data.Monoid ((<>)) + import Data.Text (Text) import Codec.Encryption.OpenPGP.Types diff --git a/Codec/Encryption/OpenPGP/S2K.hs b/Codec/Encryption/OpenPGP/S2K.hs --- a/Codec/Encryption/OpenPGP/S2K.hs +++ b/Codec/Encryption/OpenPGP/S2K.hs @@ -12,30 +12,29 @@ import Codec.Encryption.OpenPGP.Types import Control.Monad.Loops (untilM_) import Control.Monad.Trans.State.Lazy (execState, get, put) -import Crypto.Hash (hashlazy) import qualified Crypto.Hash as CH import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL string2Key :: S2K -> Int -> BL.ByteString -> B.ByteString -string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp (hf ha) ksz bs +string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp ha ksz bs string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt salt)) bs) string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromStrict (unSalt salt)) bs) string2Key _ _ _ = error "FIXME: unimplemented S2K type" -hf :: HashAlgorithm -> BL.ByteString -> B.ByteString -hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1) -hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512) -hf _ _ = error "FIXME: unimplemented S2K hash" - skesk2Key :: SKESK -> BL.ByteString -> B.ByteString skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass skesk2Key _ _ = error "FIXME" -hashpp :: (BL.ByteString -> B.ByteString) -> Int -> BL.ByteString -> B.ByteString -hashpp hf keysize pp = snd (execState (hashround `untilM_` bigEnough) (0, B.empty)) +hashpp :: HashAlgorithm -> Int -> BL.ByteString -> B.ByteString +hashpp ha keysize pp = snd (execState (hashround `untilM_` bigEnough) (0, B.empty)) where - hashround = get >>= \(ctr, bs) -> put (ctr + 1, bs `B.append` hf (nulpad ctr `BL.append` pp)) + hashround = get >>= \(ctr, bs) -> put (ctr + 1, bs `B.append` hf ha (nulpad ctr `BL.append` pp)) nulpad = BL.pack . flip replicate 0 bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize) + hf :: HashAlgorithm -> BL.ByteString -> B.ByteString + hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1) + hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512) + hf _ _ = error "FIXME: unimplemented S2K hash" + diff --git a/Codec/Encryption/OpenPGP/SecretKey.hs b/Codec/Encryption/OpenPGP/SecretKey.hs --- a/Codec/Encryption/OpenPGP/SecretKey.hs +++ b/Codec/Encryption/OpenPGP/SecretKey.hs @@ -17,7 +17,6 @@ import Codec.Encryption.OpenPGP.Serialize (getSecretKey) import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key) import qualified Crypto.Hash as CH -import qualified Crypto.Hash.Algorithms as CHA import Crypto.Random.EntropyPool (createEntropyPool, getEntropyFrom) import qualified Data.ByteArray as BA import qualified Data.ByteString as B @@ -28,6 +27,7 @@ import Data.Bifunctor (bimap) import qualified Crypto.PubKey.RSA as R +saBlockSize :: SymmetricAlgorithm -> Int saBlockSize sa = either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize)) decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum 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 @@ -3,12 +3,17 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE CPP #-} + module Codec.Encryption.OpenPGP.Serialize ( putSKAddendum , getSecretKey ) where -import Control.Applicative ((<$>), many, some) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Applicative (many, some) import Control.Lens ((^.), _1) import Control.Monad (guard, liftM, replicateM, replicateM_) import Crypto.Number.Basic (numBits) @@ -25,7 +30,9 @@ 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 +#if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) +#endif import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T @@ -35,7 +42,7 @@ import Data.Maybe (fromMaybe) import Network.URI (nullURI, parseURI, uriToString) -import Codec.Encryption.OpenPGP.Internal (countBits, pubkeyToMPIs, multiplicativeInverse) +import Codec.Encryption.OpenPGP.Internal (pubkeyToMPIs, multiplicativeInverse) import Codec.Encryption.OpenPGP.Types instance Binary SigSubPacket where @@ -875,15 +882,16 @@ putSKAddendum _ = fail "Type not supported" symEncBlockSize :: SymmetricAlgorithm -> Int -symEncBlockSize (Plaintext) = 0 -symEncBlockSize (IDEA) = 8 -symEncBlockSize (TripleDES) = 8 -symEncBlockSize (CAST5) = 8 -symEncBlockSize (Blowfish) = 8 -symEncBlockSize (AES128) = 16 -symEncBlockSize (AES192) = 16 -symEncBlockSize (AES256) = 16 -symEncBlockSize (Twofish) = 16 +symEncBlockSize Plaintext = 0 +symEncBlockSize IDEA = 8 +symEncBlockSize TripleDES = 8 +symEncBlockSize CAST5 = 8 +symEncBlockSize Blowfish = 8 +symEncBlockSize AES128 = 16 +symEncBlockSize AES192 = 16 +symEncBlockSize AES256 = 16 +symEncBlockSize Twofish = 16 +symEncBlockSize Camellia128 = 16 symEncBlockSize _ = 8 -- FIXME decodeIterationCount :: Word8 -> IterationCount diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -20,7 +20,7 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Data.Binary (Binary, put) +import Data.Binary (put) import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, runPut) import Data.Text.Encoding (encodeUtf8) 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 @@ -3,6 +3,8 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE CPP #-} + module Codec.Encryption.OpenPGP.Signatures ( verifySigWith , verifyAgainstKeyring @@ -10,7 +12,9 @@ , verifyTKWith ) where -import Control.Applicative ((<$>),(<*>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif import Control.Error.Util (hush) import Control.Lens ((^.), _1) import Control.Monad (liftM2) 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 @@ -3,1612 +3,10 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Codec.Encryption.OpenPGP.Types where - -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 -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import Data.Aeson ((.=), object) -import qualified Data.Aeson as A -import Data.Byteable (Byteable) -import Data.ByteArray (ByteArrayAccess) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Char (toLower, toUpper) -import Data.Data (Data) -import Data.Hashable (Hashable(..)) -import Data.IxSet.Typed (IxSet) -import Data.List (unfoldr) -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) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Time.Format (formatTime) -import Data.Typeable (Typeable) -import Data.Word (Word8, Word16, Word32) -import Network.URI (URI(..), uriToString, nullURI, parseURI) -import Numeric (readHex, showHex) -import Data.Time.Locale.Compat (defaultTimeLocale) -import Text.PrettyPrint.Free (Pretty(..), (<+>), char, hsep, punctuate, space, text, tupled) - -type Exportability = Bool -type TrustLevel = Word8 -type TrustAmount = Word8 -type AlmostPublicDomainRegex = ByteString -type Revocability = Bool -type RevocationReason = Text -type KeyServer = ByteString -type SignatureHash = ByteString -type PacketVersion = Word8 -type V3Expiration = Word16 -type CompressedDataPayload = ByteString -type FileName = ByteString -type ImageData = ByteString -type NestedFlag = Bool - -data SymmetricAlgorithm = Plaintext - | IDEA - | TripleDES - | CAST5 - | Blowfish - | ReservedSAFER - | ReservedDES - | AES128 - | AES192 - | AES256 - | Twofish - | OtherSA Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq SymmetricAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord SymmetricAlgorithm where - compare = comparing fromFVal - -instance FutureVal SymmetricAlgorithm where - fromFVal Plaintext = 0 - fromFVal IDEA = 1 - fromFVal TripleDES = 2 - fromFVal CAST5 = 3 - fromFVal Blowfish = 4 - fromFVal ReservedSAFER = 5 - fromFVal ReservedDES = 6 - fromFVal AES128 = 7 - fromFVal AES192 = 8 - fromFVal AES256 = 9 - fromFVal Twofish = 10 - fromFVal (OtherSA o) = o - toFVal 0 = Plaintext - toFVal 1 = IDEA - toFVal 2 = TripleDES - toFVal 3 = CAST5 - toFVal 4 = Blowfish - toFVal 5 = ReservedSAFER - toFVal 6 = ReservedDES - toFVal 7 = AES128 - toFVal 8 = AES192 - toFVal 9 = AES256 - toFVal 10 = Twofish - toFVal o = OtherSA o - -instance Hashable SymmetricAlgorithm - -instance Pretty SymmetricAlgorithm where - pretty Plaintext = text "plaintext" - pretty IDEA = text "IDEA" - pretty TripleDES = text "3DES" - pretty CAST5 = text "CAST-128" - pretty Blowfish = text "Blowfish" - pretty ReservedSAFER = text "(reserved) SAFER" - pretty ReservedDES = text "(reserved) DES" - pretty AES128 = text "AES-128" - pretty AES192 = text "AES-192" - pretty AES256 = text "AES-256" - pretty Twofish = text "Twofish" - 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? - deriving (Data, Generic, Show, Typeable) - -instance Eq NotationFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord NotationFlag where - compare = comparing fromFFlag - -instance FutureFlag NotationFlag where - fromFFlag HumanReadable = 0 - fromFFlag (OtherNF o) = fromIntegral o - - toFFlag 0 = HumanReadable - toFFlag o = OtherNF (fromIntegral o) - -instance Hashable NotationFlag - -instance Pretty NotationFlag where - pretty HumanReadable = text "human-readable" - pretty (OtherNF o) = text "unknown notation flag type" <+> pretty o - -instance A.ToJSON NotationFlag -instance A.FromJSON NotationFlag - -data SigSubPacket = SigSubPacket { - _sspCriticality :: Bool - , _sspPayload :: SigSubPacketPayload - } deriving (Data, Eq, Generic, Show, Typeable) - -instance Pretty SigSubPacket where - pretty x = (if _sspCriticality x then char '*' else mempty) <> (pretty . _sspPayload) x - -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) - -instance Newtype ThirtyTwoBitTimeStamp Word32 where - pack = ThirtyTwoBitTimeStamp - unpack (ThirtyTwoBitTimeStamp o) = o - -instance Pretty ThirtyTwoBitTimeStamp where - 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) - -instance Newtype ThirtyTwoBitDuration Word32 where - pack = ThirtyTwoBitDuration - unpack (ThirtyTwoBitDuration o) = o - -instance Pretty ThirtyTwoBitDuration where - 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 - | x >= 31557600 = Just ((++"y") . show $ x `div` 31557600, x `mod` 31557600) - | x >= 2629800 = Just ((++"m") . show $ x `div` 2629800, x `mod` 2629800) - | x >= 86400 = Just ((++"d") . show $ x `div` 86400, x `mod` 86400) - | x > 0 = Just ((++"s") . show $ x, 0) - | otherwise = Nothing - -newtype URL = URL {unURL :: URI} - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Newtype URL URI where - pack = URL - unpack (URL o) = o - -instance Hashable URL where - hashWithSalt salt (URL (URI s a p q f)) = salt `hashWithSalt` s `hashWithSalt` show a `hashWithSalt` p `hashWithSalt` q `hashWithSalt` f - -instance Pretty URL where - pretty = pretty . (\uri -> uriToString id uri "") . unpack - -instance A.ToJSON URL where - 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 - | TrustSignature TrustLevel TrustAmount - | RegularExpression AlmostPublicDomainRegex - | Revocable Revocability - | KeyExpirationTime ThirtyTwoBitDuration - | PreferredSymmetricAlgorithms [SymmetricAlgorithm] - | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint - | Issuer EightOctetKeyId - | NotationData (Set NotationFlag) NotationName NotationValue - | PreferredHashAlgorithms [HashAlgorithm] - | PreferredCompressionAlgorithms [CompressionAlgorithm] - | KeyServerPreferences (Set KSPFlag) - | PreferredKeyServer KeyServer - | PrimaryUserId Bool - | PolicyURL URL - | KeyFlags (Set KeyFlag) - | SignersUserId Text - | ReasonForRevocation RevocationCode RevocationReason - | Features (Set FeatureFlag) - | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash - | EmbeddedSignature SignaturePayload - | UserDefinedSigSub Word8 ByteString - | OtherSigSub Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) -- FIXME - -instance Hashable SigSubPacketPayload - -instance Pretty SigSubPacketPayload where - pretty (SigCreationTime ts) = text "creation-time" <+> pretty ts - pretty (SigExpirationTime d) = text "sig expiration time" <+> pretty d - pretty (ExportableCertification e) = text "exportable certification" <+> pretty e - pretty (TrustSignature tl ta) = text "trust signature" <+> pretty tl <+> pretty ta - pretty (RegularExpression apdre) = text "regular expression" <+> pretty apdre - pretty (Revocable r) = text "revocable" <+> pretty r - pretty (KeyExpirationTime d) = text "key expiration time" <+> pretty d - pretty (PreferredSymmetricAlgorithms sas) = text "preferred symmetric algorithms" <+> prettyList sas - pretty (RevocationKey rcs pka tof) = text "revocation key" <+> prettyList (Set.toList rcs) <+> pretty pka <+> pretty tof - pretty (Issuer eoki) = text "issuer" <+> pretty eoki - pretty (NotationData nfs nn nv) = text "notation data" <+> prettyList (Set.toList nfs) <+> pretty nn <+> pretty nv - pretty (PreferredHashAlgorithms phas) = text "preferred hash algorithms" <+> prettyList phas - pretty (PreferredCompressionAlgorithms pcas) = text "preferred compression algorithms" <+> pretty pcas - pretty (KeyServerPreferences kspfs) = text "keyserver preferences" <+> prettyList (Set.toList kspfs) - pretty (PreferredKeyServer ks) = text "preferred keyserver" <+> pretty ks - pretty (PrimaryUserId p) = (if p then mempty else text "NOT ") <> text "primary user-ID" - pretty (PolicyURL u) = text "policy URL" <+> pretty u - pretty (KeyFlags kfs) = text "key flags" <+> prettyList (Set.toList kfs) - pretty (SignersUserId u) = text "signer's user-ID" <+> pretty u - pretty (ReasonForRevocation rc rr) = text "reason for revocation" <+> pretty rc <+> pretty rr - pretty (Features ffs) = text "features" <+> prettyList (Set.toList ffs) - pretty (SignatureTarget pka ha sh) = text "signature target" <+> pretty pka <+> pretty ha <+> pretty sh - pretty (EmbeddedSignature sp) = text "embedded signature" <+> pretty sp - pretty (UserDefinedSigSub t bs) = text "user-defined signature subpacket type" <+> pretty t <+> pretty (BL.unpack bs) - pretty (OtherSigSub t bs) = text "unknown signature subpacket type" <+> pretty t <+> pretty bs - -instance A.ToJSON SigSubPacketPayload where - 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 - | SHA256 - | SHA384 - | SHA512 - | SHA224 - | OtherHA Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq HashAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord HashAlgorithm where - compare = comparing fromFVal - -instance FutureVal HashAlgorithm where - fromFVal DeprecatedMD5 = 1 - fromFVal SHA1 = 2 - fromFVal RIPEMD160 = 3 - fromFVal SHA256 = 8 - fromFVal SHA384 = 9 - fromFVal SHA512 = 10 - fromFVal SHA224 = 11 - fromFVal (OtherHA o) = o - toFVal 1 = DeprecatedMD5 - toFVal 2 = SHA1 - toFVal 3 = RIPEMD160 - toFVal 8 = SHA256 - toFVal 9 = SHA384 - toFVal 10 = SHA512 - toFVal 11 = SHA224 - toFVal o = OtherHA o - -instance Hashable HashAlgorithm - -instance Pretty HashAlgorithm where - pretty DeprecatedMD5 = text "(deprecated) MD5" - pretty SHA1 = text "SHA-1" - pretty RIPEMD160 = text "RIPEMD-160" - pretty SHA256 = text "SHA-256" - pretty SHA384 = text "SHA-384" - pretty SHA512 = text "SHA-512" - pretty SHA224 = text "SHA-224" - pretty (OtherHA ha) = text "unknown hash algorithm type" <+> (text . show) ha - -instance A.ToJSON HashAlgorithm -instance A.FromJSON HashAlgorithm - -data CompressionAlgorithm = Uncompressed - | ZIP - | ZLIB - | BZip2 - | OtherCA Word8 - deriving (Show, Data, Generic, Typeable) - -instance Eq CompressionAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord CompressionAlgorithm where - compare = comparing fromFVal - -instance FutureVal CompressionAlgorithm where - fromFVal Uncompressed = 0 - fromFVal ZIP = 1 - fromFVal ZLIB = 2 - fromFVal BZip2 = 3 - fromFVal (OtherCA o) = o - toFVal 0 = Uncompressed - toFVal 1 = ZIP - toFVal 2 = ZLIB - toFVal 3 = BZip2 - toFVal o = OtherCA o - -instance Hashable CompressionAlgorithm - -instance Pretty CompressionAlgorithm where - pretty Uncompressed = text "uncompressed" - pretty ZIP = text "ZIP" - pretty ZLIB = text "zlib" - pretty BZip2 = text "bzip2" - 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 - toFVal :: Word8 -> a - -data PubKeyAlgorithm = RSA - | DeprecatedRSAEncryptOnly - | DeprecatedRSASignOnly - | ElgamalEncryptOnly - | DSA - | ECDH - | ECDSA - | ForbiddenElgamal - | DH - | OtherPKA Word8 - deriving (Show, Data, Generic, Typeable) - -instance Eq PubKeyAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord PubKeyAlgorithm where - compare = comparing fromFVal - -instance FutureVal PubKeyAlgorithm where - fromFVal RSA = 1 - fromFVal DeprecatedRSAEncryptOnly = 2 - fromFVal DeprecatedRSASignOnly = 3 - fromFVal ElgamalEncryptOnly = 16 - fromFVal DSA = 17 - fromFVal ECDH = 18 - fromFVal ECDSA = 19 - fromFVal ForbiddenElgamal = 20 - fromFVal DH = 21 - fromFVal (OtherPKA o) = o - toFVal 1 = RSA - toFVal 2 = DeprecatedRSAEncryptOnly - toFVal 3 = DeprecatedRSASignOnly - toFVal 16 = ElgamalEncryptOnly - toFVal 17 = DSA - toFVal 18 = ECDH - toFVal 19 = ECDSA - toFVal 20 = ForbiddenElgamal - toFVal 21 = DH - toFVal o = OtherPKA o - -instance Hashable PubKeyAlgorithm - -instance Pretty PubKeyAlgorithm where - pretty RSA = text "RSA" - pretty DeprecatedRSAEncryptOnly = text "(deprecated) RSA encrypt-only" - pretty DeprecatedRSASignOnly = text "(deprecated) RSA sign-only" - pretty ElgamalEncryptOnly = text "Elgamal encrypt-only" - pretty DSA = text "DSA" - pretty ECDH = text "ECDH" - pretty ECDSA = text "ECDSA" - pretty ForbiddenElgamal = text "(forbidden) Elgamal" - pretty DH = text "DH" - 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 - toFFlag :: Int -> a - -data KSPFlag = NoModify - | KSPOther Int - deriving (Data, Generic, Show, Typeable) - -instance Eq KSPFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord KSPFlag where - compare = comparing fromFFlag - -instance FutureFlag KSPFlag where - fromFFlag NoModify = 0 - fromFFlag (KSPOther i) = fromIntegral i - - toFFlag 0 = NoModify - toFFlag i = KSPOther (fromIntegral i) - -instance Hashable KSPFlag - -instance Pretty KSPFlag where - pretty NoModify = text "no-modify" - pretty (KSPOther o) = text "unknown keyserver preference flag type" <+> pretty o - -instance A.ToJSON KSPFlag -instance A.FromJSON KSPFlag - -data KeyFlag = GroupKey - | AuthKey - | SplitKey - | EncryptStorageKey - | EncryptCommunicationsKey - | SignDataKey - | CertifyKeysKey - | KFOther Int - deriving (Data, Generic, Show, Typeable) - -instance Eq KeyFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord KeyFlag where - compare = comparing fromFFlag - -instance FutureFlag KeyFlag where - fromFFlag GroupKey = 0 - fromFFlag AuthKey = 2 - fromFFlag SplitKey = 3 - fromFFlag EncryptStorageKey = 4 - fromFFlag EncryptCommunicationsKey = 5 - fromFFlag SignDataKey = 6 - fromFFlag CertifyKeysKey = 7 - fromFFlag (KFOther i) = fromIntegral i - - toFFlag 0 = GroupKey - toFFlag 2 = AuthKey - toFFlag 3 = SplitKey - toFFlag 4 = EncryptStorageKey - toFFlag 5 = EncryptCommunicationsKey - toFFlag 6 = SignDataKey - toFFlag 7 = CertifyKeysKey - toFFlag i = KFOther (fromIntegral i) - -instance Hashable KeyFlag - -instance Pretty KeyFlag where - pretty GroupKey = text "group" - pretty AuthKey = text "auth" - pretty SplitKey = text "split" - pretty EncryptStorageKey = text "encrypt-storage" - pretty EncryptCommunicationsKey = text "encrypt-communications" - pretty SignDataKey = text "sign-data" - pretty CertifyKeysKey = text "certify-keys" - 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 - deriving (Data, Generic, Show, Typeable) - -instance Eq RevocationClass where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord RevocationClass where - compare = comparing fromFFlag - -instance FutureFlag RevocationClass where - fromFFlag SensitiveRK = 1 - fromFFlag (RClOther i) = fromIntegral i - - toFFlag 1 = SensitiveRK - toFFlag i = RClOther (fromIntegral i) - -instance Hashable RevocationClass - -instance Pretty RevocationClass where - pretty SensitiveRK = text "sensitive" - pretty (RClOther o) = text "unknown revocation class" <+> pretty o - -instance A.ToJSON RevocationClass -instance A.FromJSON RevocationClass - -data RevocationCode = NoReason - | KeySuperseded - | KeyMaterialCompromised - | KeyRetiredAndNoLongerUsed - | UserIdInfoNoLongerValid - | RCoOther Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq RevocationCode where - (==) a b = fromFVal a == fromFVal b - -instance Ord RevocationCode where - compare = comparing fromFVal - -instance FutureVal RevocationCode where - fromFVal NoReason = 0 - fromFVal KeySuperseded = 1 - fromFVal KeyMaterialCompromised = 2 - fromFVal KeyRetiredAndNoLongerUsed = 3 - fromFVal UserIdInfoNoLongerValid = 32 - fromFVal (RCoOther o) = o - toFVal 0 = NoReason - toFVal 1 = KeySuperseded - toFVal 2 = KeyMaterialCompromised - toFVal 3 = KeyRetiredAndNoLongerUsed - toFVal 32 = UserIdInfoNoLongerValid - toFVal o = RCoOther o - -instance Hashable RevocationCode - -instance Pretty RevocationCode where - pretty NoReason = text "no reason" - pretty KeySuperseded = text "key superseded" - pretty KeyMaterialCompromised = text "key material compromised" - pretty KeyRetiredAndNoLongerUsed = text "key retired and no longer used" - pretty UserIdInfoNoLongerValid = text "user-ID info no longer valid" - pretty (RCoOther o) = text "unknown revocation code" <+> pretty o - -instance A.ToJSON RevocationCode -instance A.FromJSON RevocationCode - -data FeatureFlag = ModificationDetection - | FeatureOther Int - deriving (Data, Generic, Show, Typeable) - -instance Eq FeatureFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord FeatureFlag where - compare = comparing fromFFlag - -instance FutureFlag FeatureFlag where - fromFFlag ModificationDetection = 7 - fromFFlag (FeatureOther i) = fromIntegral i - - toFFlag 7 = ModificationDetection - toFFlag i = FeatureOther (fromIntegral i) - -instance Hashable FeatureFlag -instance Hashable a => Hashable (Set a) where - hashWithSalt salt = hashWithSalt salt . Set.toList - -instance Pretty FeatureFlag where - pretty ModificationDetection = text "modification-detection" - 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) - -instance Newtype MPI Integer where - pack = MPI - unpack (MPI o) = o - -instance Hashable MPI - -instance Pretty MPI where - 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) - | SigVOther Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable SignaturePayload - -instance Pretty SignaturePayload where - pretty (SigV3 st ts eoki pka ha w16 mpis) = text "signature v3" <> char ':' <+> pretty st <+> pretty ts <+> pretty eoki <+> pretty pka <+> pretty ha <+> pretty w16 <+> (prettyList . NE.toList) mpis - pretty (SigV4 st pka ha hsps usps w16 mpis) = text "signature v4" <> char ':' <+> pretty st <+> pretty pka <+> pretty ha <+> prettyList hsps <+> prettyList usps <+> pretty w16 <+> (prettyList . NE.toList) mpis - pretty (SigVOther t bs) = text "unknown signature v" <> pretty t <> char ':' <+> pretty (BL.unpack bs) - -instance A.ToJSON SignaturePayload where - toJSON (SigV3 st ts eoki pka ha w16 mpis) = A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis) - toJSON (SigV4 st pka ha hsps usps w16 mpis) = A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis) - toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs) - -data KeyVersion = DeprecatedV3 | V4 - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Hashable KeyVersion - -instance Pretty KeyVersion where - pretty DeprecatedV3 = text "(deprecated) v3" - pretty V4 = text "v4" - -instance A.ToJSON KeyVersion -instance A.FromJSON KeyVersion - -data PKPayload = PKPayload { - _keyVersion :: KeyVersion - , _timestamp :: ThirtyTwoBitTimeStamp - , _v3exp :: V3Expiration - , _pkalgo :: PubKeyAlgorithm - , _pubkey :: PKey - } deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord PKPayload where - compare = comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> comparing _pkalgo <> comparing _pubkey - -instance Hashable PKPayload - -instance Pretty PKPayload where - pretty (PKPayload kv ts v3e pka p) = pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p - -instance A.ToJSON PKPayload - -newtype IV = IV {unIV :: B.ByteString} - deriving (Byteable, ByteArrayAccess, Data, Eq, Generic, Hashable, Monoid, Show, Typeable) - -instance Newtype IV B.ByteString where - pack = IV - unpack (IV o) = o - -instance Pretty IV where - pretty = pretty . unpack - -instance A.ToJSON IV where - toJSON = A.toJSON . show . unpack - -data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString - | SUSSHA1 SymmetricAlgorithm S2K IV ByteString - | SUSym SymmetricAlgorithm IV ByteString - | SUUnencrypted SKey Word16 - deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord SKAddendum where - compare a b = show a `compare` show b -- FIXME: this is ridiculous - -instance Hashable SKAddendum - -instance Pretty SKAddendum where - pretty (SUS16bit sa s2k iv bs) = text "SUS16bit" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty bs - pretty (SUSSHA1 sa s2k iv bs) = text "SUSSHA1" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty bs - pretty (SUSym sa iv bs) = text "SUSym" <+> pretty sa <+> pretty iv <+> pretty bs - pretty (SUUnencrypted s ck) = text "SUUnencrypted" <+> pretty s <+> pretty ck - -instance A.ToJSON SKAddendum where - toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) - toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) - toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs) - toJSON (SUUnencrypted s ck) = A.toJSON (s, ck) - -data DataType = BinaryData - | TextData - | UTF8Data - | OtherData Word8 - deriving (Show, Data, Generic, Typeable) - -instance Hashable DataType - -instance Eq DataType where - (==) a b = fromFVal a == fromFVal b - -instance Ord DataType where - compare = comparing fromFVal - -instance FutureVal DataType where - fromFVal BinaryData = fromIntegral . fromEnum $ 'b' - fromFVal TextData = fromIntegral . fromEnum $ 't' - fromFVal UTF8Data = fromIntegral . fromEnum $ 'u' - fromFVal (OtherData o) = o - - toFVal 0x62 = BinaryData - toFVal 0x74 = TextData - toFVal 0x75 = UTF8Data - toFVal o = OtherData o - -instance Pretty DataType where - pretty BinaryData = text "binary" - pretty TextData = text "text" - pretty UTF8Data = text "UTF-8" - 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) - -instance Newtype Salt B.ByteString where - pack = Salt - unpack (Salt o) = o - -instance Pretty Salt where - pretty = pretty . unpack - -instance A.ToJSON Salt where - toJSON = A.toJSON . show . unpack - -newtype IterationCount = IterationCount {unIterationCount :: Int} - deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable) - -instance Newtype IterationCount Int where - pack = IterationCount - unpack (IterationCount o) = o - -instance Pretty IterationCount where - pretty = pretty . unpack - -instance A.ToJSON IterationCount -instance A.FromJSON IterationCount - -data S2K = Simple HashAlgorithm - | Salted HashAlgorithm Salt - | IteratedSalted HashAlgorithm Salt IterationCount - | OtherS2K Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable S2K - -instance Pretty S2K where - pretty (Simple ha) = text "simple S2K," <+> pretty ha - pretty (Salted ha salt) = text "simple S2K," <+> pretty ha <+> pretty salt - pretty (IteratedSalted ha salt icount) = text "simple S2K," <+> pretty ha <+> pretty salt <+> pretty icount - pretty (OtherS2K t bs) = text "unknown S2K type" <+> pretty t <+> pretty bs - -instance A.ToJSON S2K where - toJSON (Simple ha) = A.toJSON ha - toJSON (Salted ha salt) = A.toJSON (ha, salt) - toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount) - toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs) - -data UserAttrSubPacket = ImageAttribute ImageHeader ImageData - | OtherUASub Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable UserAttrSubPacket - -instance Ord UserAttrSubPacket where - compare (ImageAttribute h1 d1) (ImageAttribute h2 d2) = compare h1 h2 <> compare d1 d2 - compare (ImageAttribute _ _) (OtherUASub _ _) = LT - compare (OtherUASub _ _) (ImageAttribute _ _) = GT - compare (OtherUASub t1 b1) (OtherUASub t2 b2) = compare t1 t2 <> compare b1 b2 - -instance Pretty UserAttrSubPacket where - pretty (ImageAttribute ih d) = text "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) - pretty (OtherUASub t bs) = text "unknown attribute type" <> (text . show) t <+> pretty (BL.unpack bs) - -instance A.ToJSON UserAttrSubPacket where - toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) - toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) - -data ImageHeader = ImageHV1 ImageFormat - deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord ImageHeader where - compare (ImageHV1 a) (ImageHV1 b) = compare a b - -instance Hashable ImageHeader - -instance Pretty ImageHeader where - pretty (ImageHV1 f) = text "imghdr v1" <+> pretty f - -instance A.ToJSON ImageHeader -instance A.FromJSON ImageHeader - -data ImageFormat = JPEG - | OtherImage Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq ImageFormat where - (==) a b = fromFVal a == fromFVal b - -instance Ord ImageFormat where - compare = comparing fromFVal - -instance FutureVal ImageFormat where - fromFVal JPEG = 1 - fromFVal (OtherImage o) = o - - toFVal 1 = JPEG - toFVal o = OtherImage o - -instance Hashable ImageFormat - -instance Pretty ImageFormat where - pretty JPEG = text "JPEG" - pretty (OtherImage o) = text "unknown image format" <+> pretty o - -instance A.ToJSON ImageFormat -instance A.FromJSON ImageFormat - -data SigType = BinarySig - | CanonicalTextSig - | StandaloneSig - | GenericCert - | PersonaCert - | CasualCert - | PositiveCert - | SubkeyBindingSig - | PrimaryKeyBindingSig - | SignatureDirectlyOnAKey - | KeyRevocationSig - | SubkeyRevocationSig - | CertRevocationSig - | TimestampSig - | ThirdPartyConfirmationSig - | OtherSig Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq SigType where - (==) a b = fromFVal a == fromFVal b - -instance Ord SigType where - compare = comparing fromFVal - -instance FutureVal SigType where - fromFVal BinarySig = 0x00 - fromFVal CanonicalTextSig = 0x01 - fromFVal StandaloneSig = 0x02 - fromFVal GenericCert = 0x10 - fromFVal PersonaCert = 0x11 - fromFVal CasualCert = 0x12 - fromFVal PositiveCert = 0x13 - fromFVal SubkeyBindingSig = 0x18 - fromFVal PrimaryKeyBindingSig = 0x19 - fromFVal SignatureDirectlyOnAKey = 0x1F - fromFVal KeyRevocationSig = 0x20 - fromFVal SubkeyRevocationSig = 0x28 - fromFVal CertRevocationSig = 0x30 - fromFVal TimestampSig = 0x40 - fromFVal ThirdPartyConfirmationSig = 0x50 - fromFVal (OtherSig o) = o - - toFVal 0x00 = BinarySig - toFVal 0x01 = CanonicalTextSig - toFVal 0x02 = StandaloneSig - toFVal 0x10 = GenericCert - toFVal 0x11 = PersonaCert - toFVal 0x12 = CasualCert - toFVal 0x13 = PositiveCert - toFVal 0x18 = SubkeyBindingSig - toFVal 0x19 = PrimaryKeyBindingSig - toFVal 0x1F = SignatureDirectlyOnAKey - toFVal 0x20 = KeyRevocationSig - toFVal 0x28 = SubkeyRevocationSig - toFVal 0x30 = CertRevocationSig - toFVal 0x40 = TimestampSig - toFVal 0x50 = ThirdPartyConfirmationSig - toFVal o = OtherSig o - -instance Hashable SigType - -instance Pretty SigType where - pretty BinarySig = text "binary" - pretty CanonicalTextSig = text "canonical-text" - pretty StandaloneSig = text "standalone" - pretty GenericCert = text "generic" - pretty PersonaCert = text "persona" - pretty CasualCert = text "casual" - pretty PositiveCert = text "positive" - pretty SubkeyBindingSig = text "subkey-binding" - pretty PrimaryKeyBindingSig = text "primary-key-binding" - pretty SignatureDirectlyOnAKey = text "signature directly on a key" - pretty KeyRevocationSig = text "key-revocation" - pretty SubkeyRevocationSig = text "subkey-revocation" - pretty CertRevocationSig = text "cert-revocation" - pretty TimestampSig = text "timestamp" - pretty ThirdPartyConfirmationSig = text "third-party-confirmation" - 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) -instance Ord DSA_PublicKey -instance A.ToJSON DSA_PublicKey where - toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y) -instance Pretty DSA_PublicKey where - pretty (DSA_PublicKey (DSA.PublicKey p y)) = pretty (DSA_Params p) <+> pretty y -newtype RSA_PublicKey = RSA_PublicKey {unRSA_PublicKey :: RSA.PublicKey} - deriving (Data, Eq, Generic, Show, Typeable) -instance Ord RSA_PublicKey -instance A.ToJSON RSA_PublicKey where - toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e) -instance Pretty RSA_PublicKey where - pretty (RSA_PublicKey (RSA.PublicKey size n e)) = pretty size <+> pretty n <+> pretty e -newtype ECDSA_PublicKey = ECDSA_PublicKey {unECDSA_PublicKey :: ECDSA.PublicKey} - deriving (Data, Eq, Generic, Show, Typeable) -instance Ord ECDSA_PublicKey -instance A.ToJSON ECDSA_PublicKey where - toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = A.toJSON (show curve, show q) -instance Pretty ECDSA_PublicKey where - pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = pretty (show curve, show q) -newtype DSA_PrivateKey = DSA_PrivateKey {unDSA_PrivateKey :: DSA.PrivateKey} - deriving (Data, Eq, Generic, Show, Typeable) -instance Ord DSA_PrivateKey -instance A.ToJSON DSA_PrivateKey where - toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x) -instance Pretty DSA_PrivateKey where - pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x) -newtype RSA_PrivateKey = RSA_PrivateKey {unRSA_PrivateKey :: RSA.PrivateKey} - deriving (Data, Eq, Generic, Show, Typeable) -instance Ord RSA_PrivateKey -instance A.ToJSON RSA_PrivateKey where - toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv) -instance Pretty RSA_PrivateKey where - pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = pretty (RSA_PublicKey pub) <+> tupled (map pretty [d, p, q, dP, dQ, qinv]) -newtype ECDSA_PrivateKey = ECDSA_PrivateKey {unECDSA_PrivateKey :: ECDSA.PrivateKey} - deriving (Data, Eq, Generic, Show, Typeable) -instance Ord ECDSA_PrivateKey -instance A.ToJSON ECDSA_PrivateKey where - toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = A.toJSON (show curve, show d) -instance Pretty ECDSA_PrivateKey where - pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = pretty (show curve, show d) - -newtype DSA_Params = DSA_Params {unDSA_Params :: DSA.Params} - deriving (Data, Eq, Generic, Show, Typeable) -instance A.ToJSON DSA_Params where - toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q) -instance Pretty DSA_Params where - pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q) -instance Hashable DSA_Params where - hashWithSalt s (DSA_Params (DSA.Params p g q)) = s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q -instance Hashable DSA_PublicKey where - hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) = s `hashWithSalt` DSA_Params p `hashWithSalt` y -instance Hashable DSA_PrivateKey where - hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) = s `hashWithSalt` DSA_Params p `hashWithSalt` x -instance Hashable RSA_PublicKey where - hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) = s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e -instance Hashable RSA_PrivateKey where - hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = s `hashWithSalt` RSA_PublicKey pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt` q `hashWithSalt` dP `hashWithSalt` dQ `hashWithSalt` qinv -instance Hashable ECDSA_PublicKey where - hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = s `hashWithSalt` show curve `hashWithSalt` show q -- FIXME: don't use show -instance Hashable ECDSA_PrivateKey where - hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = s `hashWithSalt` show curve `hashWithSalt` show d -- FIXME: don't use show - -data ECCCurve = BrokenNISTP256 - | BrokenNISTP384 - | BrokenNISTP521 - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Hashable ECCCurve - -data PKey = RSAPubKey RSA_PublicKey - | DSAPubKey DSA_PublicKey - | ElGamalPubKey [Integer] - | ECDHPubKey ECDSA_PublicKey HashAlgorithm SymmetricAlgorithm - | ECDSAPubKey ECDSA_PublicKey - | UnknownPKey ByteString - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Hashable PKey - -instance Pretty PKey where - pretty (RSAPubKey p) = text "RSA" <+> pretty p - pretty (DSAPubKey p) = text "DSA" <+> pretty p - pretty (ElGamalPubKey p) = text "Elgamal" <+> pretty p - pretty (ECDHPubKey p ha sa) = text "ECDH" <+> pretty p <+> pretty ha <+> pretty sa - pretty (ECDSAPubKey p) = text "ECDSA" <+> pretty p - pretty (UnknownPKey bs) = text "unknown" <+> pretty bs - -instance A.ToJSON PKey where - toJSON (RSAPubKey p) = A.toJSON p - toJSON (DSAPubKey p) = A.toJSON p - toJSON (ElGamalPubKey p) = A.toJSON p - toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa) - toJSON (ECDSAPubKey p) = A.toJSON p - toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs) - -data SKey = RSAPrivateKey RSA_PrivateKey - | DSAPrivateKey DSA_PrivateKey - | ElGamalPrivateKey [Integer] - | ECDHPrivateKey ECDSA_PrivateKey - | ECDSAPrivateKey ECDSA_PrivateKey - | UnknownSKey ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable SKey - -instance Pretty SKey where - pretty (RSAPrivateKey p) = text "RSA" <+> pretty p - pretty (DSAPrivateKey p) = text "DSA" <+> pretty p - pretty (ElGamalPrivateKey p) = text "Elgamal" <+> pretty p - pretty (ECDHPrivateKey p) = text "ECDH" <+> pretty p - pretty (ECDSAPrivateKey p) = text "ECDSA" <+> pretty p - pretty (UnknownSKey bs) = text "unknown" <+> pretty bs - -instance A.ToJSON SKey where - toJSON (RSAPrivateKey k) = A.toJSON k - toJSON (DSAPrivateKey k) = A.toJSON k - toJSON (ElGamalPrivateKey k) = A.toJSON k - toJSON (ECDHPrivateKey k) = A.toJSON k - toJSON (ECDSAPrivateKey k) = A.toJSON k - toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs) - -newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance - deriving (Show, Eq) - -newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString} - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Newtype EightOctetKeyId ByteString where - pack = EightOctetKeyId - unpack (EightOctetKeyId o) = o - -instance Pretty EightOctetKeyId where - pretty = text . w8sToHex . BL.unpack . unpack - --- FIXME: read-show -instance Read EightOctetKeyId where - readsPrec _ = map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s - -instance Hashable EightOctetKeyId - -instance A.ToJSON EightOctetKeyId where - 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) - -instance Newtype TwentyOctetFingerprint ByteString where - pack = TwentyOctetFingerprint - unpack (TwentyOctetFingerprint o) = o - --- FIXME: read-show -instance Read TwentyOctetFingerprint where - readsPrec _ = map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ') - -instance Hashable TwentyOctetFingerprint - -instance Pretty TwentyOctetFingerprint where - pretty = text . take 40 . w8sToHex . BL.unpack . unTOF - -instance A.ToJSON TwentyOctetFingerprint where - 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 } - -instance Newtype SpacedFingerprint TwentyOctetFingerprint where - pack = SpacedFingerprint - unpack (SpacedFingerprint o) = o - -instance Pretty SpacedFingerprint where - pretty = hsep . punctuate space . map hsep . chunksOf 5 . map text . chunksOf 4 . take 40 . w8sToHex . BL.unpack . unTOF . unpack - -w8sToHex :: [Word8] -> String -w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "") - -hexToW8s :: ReadS Word8 -hexToW8s = concatMap readHex . chunksOf 2 . map toLower - -data TK = TK { - _tkKey :: (PKPayload, Maybe SKAddendum) - , _tkRevs :: [SignaturePayload] - , _tkUIDs :: [(Text, [SignaturePayload])] - , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] - , _tkSubs :: [(Pkt, [SignaturePayload])] - } deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord TK where - compare = comparing _tkKey -- FIXME: is this ridiculous? - -instance A.ToJSON TK - -type KeyringIxs = '[EightOctetKeyId, TwentyOctetFingerprint, Text] -type Keyring = IxSet KeyringIxs TK - -class Packet a where - data PacketType a :: * - packetType :: a -> PacketType a - packetCode :: PacketType a -> Word8 - toPkt :: a -> Pkt - fromPkt :: Pkt -> a - --- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a -data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI) - | SignaturePkt SignaturePayload - | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString) - | OnePassSignaturePkt PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag - | SecretKeyPkt PKPayload SKAddendum - | PublicKeyPkt PKPayload - | SecretSubkeyPkt PKPayload SKAddendum - | CompressedDataPkt CompressionAlgorithm CompressedDataPayload - | SymEncDataPkt ByteString - | MarkerPkt ByteString - | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString - | TrustPkt ByteString - | UserIdPkt Text - | PublicSubkeyPkt PKPayload - | UserAttributePkt [UserAttrSubPacket] - | SymEncIntegrityProtectedDataPkt PacketVersion ByteString - | ModificationDetectionCodePkt ByteString - | OtherPacketPkt Word8 ByteString - | BrokenPacketPkt String Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) -- FIXME - -instance Hashable Pkt - -instance Ord Pkt where - compare = comparing pktTag <> comparing hash -- FIXME: is there something saner? - -instance Pretty Pkt where - pretty (PKESKPkt pv eoki pka mpis) = text "PKESK v" <> (text . show) pv <> char ':' <+> pretty eoki <+> pretty pka <+> (prettyList . NE.toList) mpis - pretty (SignaturePkt sp) = pretty sp - pretty (SKESKPkt pv sa s2k mbs) = text "SKESK v" <> (text . show) pv <> char ':' <+> pretty sa <+> pretty s2k <+> pretty mbs - pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = text "one-pass signature v" <> (text . show) pv <> char ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag - pretty (SecretKeyPkt pkp ska) = text "secret key:" <+> pretty pkp <+> pretty ska - pretty (PublicKeyPkt pkp) = text "public key:" <+> pretty pkp - pretty (SecretSubkeyPkt pkp ska) = text "secret subkey:" <+> pretty pkp <+> pretty ska - pretty (CompressedDataPkt ca cdp) = text "compressed-data:" <+> pretty ca <+> pretty cdp - pretty (SymEncDataPkt bs) = text "symmetrically-encrypted-data:" <+> pretty bs - pretty (MarkerPkt bs) = text "marker:" <+> pretty bs - pretty (LiteralDataPkt dt fn ts bs) = text "literal-data" <+> pretty dt <+> pretty fn <+> pretty ts <+> pretty bs - pretty (TrustPkt bs) = text "trust:" <+> pretty (BL.unpack bs) - pretty (UserIdPkt u) = text "user-ID:" <+> pretty u - pretty (PublicSubkeyPkt pkp) = text "public subkey:" <+> pretty pkp - pretty (UserAttributePkt us) = text "user-attribute:" <+> prettyList us - pretty (SymEncIntegrityProtectedDataPkt pv bs) = text "symmetrically-encrypted-integrity-protected-data v" <> (text . show) pv <> char ':' <+> pretty bs - pretty (ModificationDetectionCodePkt bs) = text "MDC:" <+> pretty bs - pretty (OtherPacketPkt t bs) = text "unknown packet type" <+> pretty t <> char ':' <+> pretty bs - pretty (BrokenPacketPkt s t bs) = text "BROKEN packet (" <> pretty s <> char ')' <+> pretty t <> char ':' <+> pretty bs - -instance A.ToJSON Pkt where - toJSON (PKESKPkt pv eoki pka mpis) = object [T.pack "pkesk" .= object [T.pack "version" .= pv, T.pack "keyid" .= eoki, T.pack "pkalgo" .= pka, T.pack "mpis" .= NE.toList mpis]] - toJSON (SignaturePkt sp) = object [T.pack "signature" .= sp] - toJSON (SKESKPkt pv sa s2k mbs) = object [T.pack "skesk" .= object [T.pack "version" .= pv, T.pack "symalgo" .= sa, T.pack "s2k" .= s2k, T.pack "data" .= maybe mempty BL.unpack mbs]] - toJSON (OnePassSignaturePkt pv st ha pka eoki nestedflag) = object [T.pack "onepasssignature" .= object [T.pack "version" .= pv, T.pack "sigtype" .= st, T.pack "hashalgo" .= ha, T.pack "pkalgo" .= pka, T.pack "keyid" .= eoki, T.pack "nested" .= nestedflag]] - toJSON (SecretKeyPkt pkp ska) = object [T.pack "secretkey" .= object [T.pack "public" .= pkp, T.pack "secret" .= ska]] - toJSON (PublicKeyPkt pkp) = object [T.pack "publickey" .= pkp] - toJSON (SecretSubkeyPkt pkp ska) = object [T.pack "secretsubkey" .= object [T.pack "public" .= pkp, T.pack "secret" .= ska]] - toJSON (CompressedDataPkt ca cdp) = object [T.pack "compresseddata" .= object [T.pack "compressionalgo" .= ca, T.pack "data" .= BL.unpack cdp]] - toJSON (SymEncDataPkt bs) = object [T.pack "symencdata" .= BL.unpack bs] - toJSON (MarkerPkt bs) = object [T.pack "marker" .= BL.unpack bs] - toJSON (LiteralDataPkt dt fn ts bs) = object [T.pack "literaldata" .= object [T.pack "dt" .= dt, T.pack "filename" .= BL.unpack fn, T.pack "ts" .= ts, T.pack "data" .= BL.unpack bs]] - toJSON (TrustPkt bs) = object [T.pack "trust" .= BL.unpack bs] - toJSON (UserIdPkt u) = object [T.pack "userid" .= u] - toJSON (PublicSubkeyPkt pkp) = object [T.pack "publicsubkkey" .= pkp] - toJSON (UserAttributePkt us) = object [T.pack "userattribute" .= us] - toJSON (SymEncIntegrityProtectedDataPkt pv bs) = object [T.pack "symencipd" .= object [T.pack "version" .= pv, T.pack "data" .= BL.unpack bs]] - toJSON (ModificationDetectionCodePkt bs) = object [T.pack "mdc" .= BL.unpack bs] - toJSON (OtherPacketPkt t bs) = object [T.pack "otherpacket" .= object [T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]] - toJSON (BrokenPacketPkt s t bs) = object [T.pack "brokenpacket" .= object [T.pack "error" .= s, T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]] - -pktTag :: Pkt -> Word8 -pktTag (PKESKPkt {}) = 1 -pktTag (SignaturePkt _) = 2 -pktTag (SKESKPkt {}) = 3 -pktTag (OnePassSignaturePkt {}) = 4 -pktTag (SecretKeyPkt {}) = 5 -pktTag (PublicKeyPkt _) = 6 -pktTag (SecretSubkeyPkt {}) = 7 -pktTag (CompressedDataPkt {}) = 8 -pktTag (SymEncDataPkt _) = 9 -pktTag (MarkerPkt _) = 10 -pktTag (LiteralDataPkt {}) = 11 -pktTag (TrustPkt _) = 12 -pktTag (UserIdPkt _) = 13 -pktTag (PublicSubkeyPkt _) = 14 -pktTag (UserAttributePkt _) = 17 -pktTag (SymEncIntegrityProtectedDataPkt {}) = 18 -pktTag (ModificationDetectionCodePkt _) = 19 -pktTag (OtherPacketPkt t _) = t - -data PKESK = PKESK - { _pkeskPacketVersion :: PacketVersion - , _pkeskEightOctetKeyId :: EightOctetKeyId - , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm - , _pkeskMPIs :: NonEmpty MPI - } deriving (Data, Eq, Show, Typeable) -instance Packet PKESK where - data PacketType PKESK = PKESKType deriving (Show, Eq) - packetType _ = PKESKType - 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 - -data Signature = Signature -- FIXME? - { _signaturePayload :: SignaturePayload - } deriving (Data, Eq, Show, Typeable) -instance Packet Signature where - data PacketType Signature = SignatureType deriving (Show, Eq) - packetType _ = SignatureType - packetCode _ = 2 - toPkt (Signature a) = SignaturePkt a - fromPkt (SignaturePkt a) = Signature a - fromPkt _ = error "Cannot coerce non-Signature packet" - -instance Pretty Signature where - pretty = pretty . toPkt - -data SKESK = SKESK - { _skeskPacketVersion :: PacketVersion - , _skeskSymmetricAlgorithm :: SymmetricAlgorithm - , _skeskS2K :: S2K - , _skeskESK :: Maybe BL.ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet SKESK where - data PacketType SKESK = SKESKType deriving (Show, Eq) - packetType _ = SKESKType - 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 - -data OnePassSignature = OnePassSignature - { _onePassSignaturePacketVersion :: PacketVersion - , _onePassSignatureSigType :: SigType - , _onePassSignatureHashAlgorithm :: HashAlgorithm - , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm - , _onePassSignatureEightOctetKeyId :: EightOctetKeyId - , _onePassSignatureNestedFlag :: NestedFlag - } deriving (Data, Eq, Show, Typeable) -instance Packet OnePassSignature where - data PacketType OnePassSignature = OnePassSignatureType deriving (Show, Eq) - packetType _ = OnePassSignatureType - 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 - -data SecretKey = SecretKey - { _secretKeyPKPayload :: PKPayload - , _secretKeySKAddendum :: SKAddendum - } deriving (Data, Eq, Show, Typeable) -instance Packet SecretKey where - data PacketType SecretKey = SecretKeyType deriving (Show, Eq) - packetType _ = SecretKeyType - 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 - -data PublicKey = PublicKey - { _publicKeyPKPayload :: PKPayload - } deriving (Data, Eq, Show, Typeable) -instance Packet PublicKey where - data PacketType PublicKey = PublicKeyType deriving (Show, Eq) - packetType _ = PublicKeyType - 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 - -data SecretSubkey = SecretSubkey - { _secretSubkeyPKPayload :: PKPayload - , _secretSubkeySKAddendum :: SKAddendum - } deriving (Data, Eq, Show, Typeable) -instance Packet SecretSubkey where - data PacketType SecretSubkey = SecretSubkeyType deriving (Show, Eq) - packetType _ = SecretSubkeyType - 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 - -data CompressedData = CompressedData - { _compressedDataCompressionAlgorithm :: CompressionAlgorithm - , _compressedDataPayload :: CompressedDataPayload - } deriving (Data, Eq, Show, Typeable) -instance Packet CompressedData where - data PacketType CompressedData = CompressedDataType deriving (Show, Eq) - packetType _ = CompressedDataType - 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 - -data SymEncData = SymEncData - { _symEncDataPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet SymEncData where - data PacketType SymEncData = SymEncDataType deriving (Show, Eq) - packetType _ = SymEncDataType - 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 - -data Marker = Marker - { _markerPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet Marker where - data PacketType Marker = MarkerType deriving (Show, Eq) - packetType _ = MarkerType - 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 - -data LiteralData = LiteralData - { _literalDataDataType :: DataType - , _literalDataFileName :: FileName - , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp - , _literalDataPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet LiteralData where - data PacketType LiteralData = LiteralDataType deriving (Show, Eq) - packetType _ = LiteralDataType - 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 - -data Trust = Trust - { _trustPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet Trust where - data PacketType Trust = TrustType deriving (Show, Eq) - packetType _ = TrustType - 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 - -data UserId = UserId - { _userIdPayload :: Text - } deriving (Data, Eq, Show, Typeable) -instance Packet UserId where - data PacketType UserId = UserIdType deriving (Show, Eq) - packetType _ = UserIdType - 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 - -data PublicSubkey = PublicSubkey - { _publicSubkeyPKPayload :: PKPayload - } deriving (Data, Eq, Show, Typeable) -instance Packet PublicSubkey where - data PacketType PublicSubkey = PublicSubkeyType deriving (Show, Eq) - packetType _ = PublicSubkeyType - 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 - -data UserAttribute = UserAttribute - { _userAttributeSubPackets :: [UserAttrSubPacket] - } deriving (Data, Eq, Show, Typeable) -instance Packet UserAttribute where - data PacketType UserAttribute = UserAttributeType deriving (Show, Eq) - packetType _ = UserAttributeType - 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 - -data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData - { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion - , _symEncIntegrityProtectedDataPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet SymEncIntegrityProtectedData where - data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType deriving (Show, Eq) - packetType _ = SymEncIntegrityProtectedDataType - 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 - -data ModificationDetectionCode = ModificationDetectionCode - { _modificationDetectionCodePayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet ModificationDetectionCode where - data PacketType ModificationDetectionCode = ModificationDetectionCodeType deriving (Show, Eq) - packetType _ = ModificationDetectionCodeType - 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 - -data OtherPacket = OtherPacket - { _otherPacketType :: Word8 - , _otherPacketPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet OtherPacket where - data PacketType OtherPacket = OtherPacketType deriving (Show, Eq) - packetType _ = OtherPacketType - 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 - -data BrokenPacket = BrokenPacket - { _brokenPacketParseError :: String - , _brokenPacketType :: Word8 - , _brokenPacketPayload :: ByteString - } deriving (Data, Eq, Show, Typeable) -instance Packet BrokenPacket where - data PacketType BrokenPacket = BrokenPacketType deriving (Show, Eq) - packetType _ = BrokenPacketType - 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 - -data Verification = Verification { - _verificationSigner :: PKPayload - , _verificationSignature :: SignaturePayload - } - -$(makeLenses ''PKESK) -$(makeLenses ''Signature) -$(makeLenses ''SKESK) -$(makeLenses ''OnePassSignature) -$(makeLenses ''SecretKey) -$(makeLenses ''PKPayload) -$(makeLenses ''PublicKey) -$(makeLenses ''SecretSubkey) -$(makeLenses ''CompressedData) -$(makeLenses ''SymEncData) -$(makeLenses ''Marker) -$(makeLenses ''LiteralData) -$(makeLenses ''Trust) -$(makeLenses ''UserId) -$(makeLenses ''PublicSubkey) -$(makeLenses ''UserAttribute) -$(makeLenses ''SymEncIntegrityProtectedData) -$(makeLenses ''ModificationDetectionCode) -$(makeLenses ''OtherPacket) -$(makeLenses ''TK) -$(makeLenses ''Verification) -$(makeLenses ''SigSubPacket) +module Codec.Encryption.OpenPGP.Types ( + module Codec.Encryption.OpenPGP.Types.Internal.Base + , module Codec.Encryption.OpenPGP.Types.Internal.PacketClass +) where + +import Codec.Encryption.OpenPGP.Types.Internal.Base +import Codec.Encryption.OpenPGP.Types.Internal.PacketClass diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -0,0 +1,1320 @@ +-- Base.hs: OpenPGP (RFC4880) data types +-- Copyright © 2012-2016 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Codec.Encryption.OpenPGP.Types.Internal.Base where + +import GHC.Generics (Generic) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +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 +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import Data.Aeson ((.=), object) +import qualified Data.Aeson as A +import Data.Byteable (Byteable) +import Data.ByteArray (ByteArrayAccess) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Char (toLower, toUpper) +import Data.Data (Data) +import Data.Hashable (Hashable(..)) +import Data.IxSet.Typed (IxSet) +import Data.List (unfoldr) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.List.Split (chunksOf) +import Data.Maybe (fromMaybe) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid, mempty) +#endif +import Data.Monoid ((<>)) +import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (formatTime) +import Data.Typeable (Typeable) +import Data.Word (Word8, Word16, Word32) +import Network.URI (URI(..), uriToString, nullURI, parseURI) +import Numeric (readHex, showHex) +import Data.Time.Locale.Compat (defaultTimeLocale) +import Text.PrettyPrint.Free (Pretty(..), (<+>), char, hsep, punctuate, space, text, tupled) + +type Exportability = Bool +type TrustLevel = Word8 +type TrustAmount = Word8 +type AlmostPublicDomainRegex = ByteString +type Revocability = Bool +type RevocationReason = Text +type KeyServer = ByteString +type SignatureHash = ByteString +type PacketVersion = Word8 +type V3Expiration = Word16 +type CompressedDataPayload = ByteString +type FileName = ByteString +type ImageData = ByteString +type NestedFlag = Bool + +data SymmetricAlgorithm = Plaintext + | IDEA + | TripleDES + | CAST5 + | Blowfish + | ReservedSAFER + | ReservedDES + | AES128 + | AES192 + | AES256 + | Twofish + | Camellia128 + | Camellia192 + | Camellia256 + | OtherSA Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq SymmetricAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord SymmetricAlgorithm where + compare = comparing fromFVal + +instance FutureVal SymmetricAlgorithm where + fromFVal Plaintext = 0 + fromFVal IDEA = 1 + fromFVal TripleDES = 2 + fromFVal CAST5 = 3 + fromFVal Blowfish = 4 + fromFVal ReservedSAFER = 5 + fromFVal ReservedDES = 6 + fromFVal AES128 = 7 + fromFVal AES192 = 8 + fromFVal AES256 = 9 + fromFVal Twofish = 10 + fromFVal Camellia128 = 11 + fromFVal Camellia192 = 12 + fromFVal Camellia256 = 13 + fromFVal (OtherSA o) = o + toFVal 0 = Plaintext + toFVal 1 = IDEA + toFVal 2 = TripleDES + toFVal 3 = CAST5 + toFVal 4 = Blowfish + toFVal 5 = ReservedSAFER + toFVal 6 = ReservedDES + toFVal 7 = AES128 + toFVal 8 = AES192 + toFVal 9 = AES256 + toFVal 10 = Twofish + toFVal 11 = Camellia128 + toFVal 12 = Camellia192 + toFVal 13 = Camellia256 + toFVal o = OtherSA o + +instance Hashable SymmetricAlgorithm + +instance Pretty SymmetricAlgorithm where + pretty Plaintext = text "plaintext" + pretty IDEA = text "IDEA" + pretty TripleDES = text "3DES" + pretty CAST5 = text "CAST-128" + pretty Blowfish = text "Blowfish" + pretty ReservedSAFER = text "(reserved) SAFER" + pretty ReservedDES = text "(reserved) DES" + pretty AES128 = text "AES-128" + pretty AES192 = text "AES-192" + pretty AES256 = text "AES-256" + pretty Twofish = text "Twofish" + pretty Camellia128 = text "Camellia-128" + pretty Camellia192 = text "Camellia-192" + pretty Camellia256 = text "Camellia-256" + 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? + deriving (Data, Generic, Show, Typeable) + +instance Eq NotationFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord NotationFlag where + compare = comparing fromFFlag + +instance FutureFlag NotationFlag where + fromFFlag HumanReadable = 0 + fromFFlag (OtherNF o) = fromIntegral o + + toFFlag 0 = HumanReadable + toFFlag o = OtherNF (fromIntegral o) + +instance Hashable NotationFlag + +instance Pretty NotationFlag where + pretty HumanReadable = text "human-readable" + pretty (OtherNF o) = text "unknown notation flag type" <+> pretty o + +instance A.ToJSON NotationFlag +instance A.FromJSON NotationFlag + +data SigSubPacket = SigSubPacket { + _sspCriticality :: Bool + , _sspPayload :: SigSubPacketPayload + } deriving (Data, Eq, Generic, Show, Typeable) + +instance Pretty SigSubPacket where + pretty x = (if _sspCriticality x then char '*' else mempty) <> (pretty . _sspPayload) x + +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) + +instance Newtype ThirtyTwoBitTimeStamp Word32 where + pack = ThirtyTwoBitTimeStamp + unpack (ThirtyTwoBitTimeStamp o) = o + +instance Pretty ThirtyTwoBitTimeStamp where + 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) + +instance Newtype ThirtyTwoBitDuration Word32 where + pack = ThirtyTwoBitDuration + unpack (ThirtyTwoBitDuration o) = o + +instance Pretty ThirtyTwoBitDuration where + 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 + | x >= 31557600 = Just ((++"y") . show $ x `div` 31557600, x `mod` 31557600) + | x >= 2629800 = Just ((++"m") . show $ x `div` 2629800, x `mod` 2629800) + | x >= 86400 = Just ((++"d") . show $ x `div` 86400, x `mod` 86400) + | x > 0 = Just ((++"s") . show $ x, 0) + | otherwise = Nothing + +newtype URL = URL {unURL :: URI} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Newtype URL URI where + pack = URL + unpack (URL o) = o + +instance Hashable URL where + hashWithSalt salt (URL (URI s a p q f)) = salt `hashWithSalt` s `hashWithSalt` show a `hashWithSalt` p `hashWithSalt` q `hashWithSalt` f + +instance Pretty URL where + pretty = pretty . (\uri -> uriToString id uri "") . unpack + +instance A.ToJSON URL where + 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 + | TrustSignature TrustLevel TrustAmount + | RegularExpression AlmostPublicDomainRegex + | Revocable Revocability + | KeyExpirationTime ThirtyTwoBitDuration + | PreferredSymmetricAlgorithms [SymmetricAlgorithm] + | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint + | Issuer EightOctetKeyId + | NotationData (Set NotationFlag) NotationName NotationValue + | PreferredHashAlgorithms [HashAlgorithm] + | PreferredCompressionAlgorithms [CompressionAlgorithm] + | KeyServerPreferences (Set KSPFlag) + | PreferredKeyServer KeyServer + | PrimaryUserId Bool + | PolicyURL URL + | KeyFlags (Set KeyFlag) + | SignersUserId Text + | ReasonForRevocation RevocationCode RevocationReason + | Features (Set FeatureFlag) + | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash + | EmbeddedSignature SignaturePayload + | UserDefinedSigSub Word8 ByteString + | OtherSigSub Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME + +instance Hashable SigSubPacketPayload + +instance Pretty SigSubPacketPayload where + pretty (SigCreationTime ts) = text "creation-time" <+> pretty ts + pretty (SigExpirationTime d) = text "sig expiration time" <+> pretty d + pretty (ExportableCertification e) = text "exportable certification" <+> pretty e + pretty (TrustSignature tl ta) = text "trust signature" <+> pretty tl <+> pretty ta + pretty (RegularExpression apdre) = text "regular expression" <+> pretty apdre + pretty (Revocable r) = text "revocable" <+> pretty r + pretty (KeyExpirationTime d) = text "key expiration time" <+> pretty d + pretty (PreferredSymmetricAlgorithms sas) = text "preferred symmetric algorithms" <+> prettyList sas + pretty (RevocationKey rcs pka tof) = text "revocation key" <+> prettyList (Set.toList rcs) <+> pretty pka <+> pretty tof + pretty (Issuer eoki) = text "issuer" <+> pretty eoki + pretty (NotationData nfs nn nv) = text "notation data" <+> prettyList (Set.toList nfs) <+> pretty nn <+> pretty nv + pretty (PreferredHashAlgorithms phas) = text "preferred hash algorithms" <+> prettyList phas + pretty (PreferredCompressionAlgorithms pcas) = text "preferred compression algorithms" <+> pretty pcas + pretty (KeyServerPreferences kspfs) = text "keyserver preferences" <+> prettyList (Set.toList kspfs) + pretty (PreferredKeyServer ks) = text "preferred keyserver" <+> pretty ks + pretty (PrimaryUserId p) = (if p then mempty else text "NOT ") <> text "primary user-ID" + pretty (PolicyURL u) = text "policy URL" <+> pretty u + pretty (KeyFlags kfs) = text "key flags" <+> prettyList (Set.toList kfs) + pretty (SignersUserId u) = text "signer's user-ID" <+> pretty u + pretty (ReasonForRevocation rc rr) = text "reason for revocation" <+> pretty rc <+> pretty rr + pretty (Features ffs) = text "features" <+> prettyList (Set.toList ffs) + pretty (SignatureTarget pka ha sh) = text "signature target" <+> pretty pka <+> pretty ha <+> pretty sh + pretty (EmbeddedSignature sp) = text "embedded signature" <+> pretty sp + pretty (UserDefinedSigSub t bs) = text "user-defined signature subpacket type" <+> pretty t <+> pretty (BL.unpack bs) + pretty (OtherSigSub t bs) = text "unknown signature subpacket type" <+> pretty t <+> pretty bs + +instance A.ToJSON SigSubPacketPayload where + 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 + | SHA256 + | SHA384 + | SHA512 + | SHA224 + | OtherHA Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq HashAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord HashAlgorithm where + compare = comparing fromFVal + +instance FutureVal HashAlgorithm where + fromFVal DeprecatedMD5 = 1 + fromFVal SHA1 = 2 + fromFVal RIPEMD160 = 3 + fromFVal SHA256 = 8 + fromFVal SHA384 = 9 + fromFVal SHA512 = 10 + fromFVal SHA224 = 11 + fromFVal (OtherHA o) = o + toFVal 1 = DeprecatedMD5 + toFVal 2 = SHA1 + toFVal 3 = RIPEMD160 + toFVal 8 = SHA256 + toFVal 9 = SHA384 + toFVal 10 = SHA512 + toFVal 11 = SHA224 + toFVal o = OtherHA o + +instance Hashable HashAlgorithm + +instance Pretty HashAlgorithm where + pretty DeprecatedMD5 = text "(deprecated) MD5" + pretty SHA1 = text "SHA-1" + pretty RIPEMD160 = text "RIPEMD-160" + pretty SHA256 = text "SHA-256" + pretty SHA384 = text "SHA-384" + pretty SHA512 = text "SHA-512" + pretty SHA224 = text "SHA-224" + pretty (OtherHA ha) = text "unknown hash algorithm type" <+> (text . show) ha + +instance A.ToJSON HashAlgorithm +instance A.FromJSON HashAlgorithm + +data CompressionAlgorithm = Uncompressed + | ZIP + | ZLIB + | BZip2 + | OtherCA Word8 + deriving (Show, Data, Generic, Typeable) + +instance Eq CompressionAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord CompressionAlgorithm where + compare = comparing fromFVal + +instance FutureVal CompressionAlgorithm where + fromFVal Uncompressed = 0 + fromFVal ZIP = 1 + fromFVal ZLIB = 2 + fromFVal BZip2 = 3 + fromFVal (OtherCA o) = o + toFVal 0 = Uncompressed + toFVal 1 = ZIP + toFVal 2 = ZLIB + toFVal 3 = BZip2 + toFVal o = OtherCA o + +instance Hashable CompressionAlgorithm + +instance Pretty CompressionAlgorithm where + pretty Uncompressed = text "uncompressed" + pretty ZIP = text "ZIP" + pretty ZLIB = text "zlib" + pretty BZip2 = text "bzip2" + 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 + toFVal :: Word8 -> a + +data PubKeyAlgorithm = RSA + | DeprecatedRSAEncryptOnly + | DeprecatedRSASignOnly + | ElgamalEncryptOnly + | DSA + | ECDH + | ECDSA + | ForbiddenElgamal + | DH + | OtherPKA Word8 + deriving (Show, Data, Generic, Typeable) + +instance Eq PubKeyAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord PubKeyAlgorithm where + compare = comparing fromFVal + +instance FutureVal PubKeyAlgorithm where + fromFVal RSA = 1 + fromFVal DeprecatedRSAEncryptOnly = 2 + fromFVal DeprecatedRSASignOnly = 3 + fromFVal ElgamalEncryptOnly = 16 + fromFVal DSA = 17 + fromFVal ECDH = 18 + fromFVal ECDSA = 19 + fromFVal ForbiddenElgamal = 20 + fromFVal DH = 21 + fromFVal (OtherPKA o) = o + toFVal 1 = RSA + toFVal 2 = DeprecatedRSAEncryptOnly + toFVal 3 = DeprecatedRSASignOnly + toFVal 16 = ElgamalEncryptOnly + toFVal 17 = DSA + toFVal 18 = ECDH + toFVal 19 = ECDSA + toFVal 20 = ForbiddenElgamal + toFVal 21 = DH + toFVal o = OtherPKA o + +instance Hashable PubKeyAlgorithm + +instance Pretty PubKeyAlgorithm where + pretty RSA = text "RSA" + pretty DeprecatedRSAEncryptOnly = text "(deprecated) RSA encrypt-only" + pretty DeprecatedRSASignOnly = text "(deprecated) RSA sign-only" + pretty ElgamalEncryptOnly = text "Elgamal encrypt-only" + pretty DSA = text "DSA" + pretty ECDH = text "ECDH" + pretty ECDSA = text "ECDSA" + pretty ForbiddenElgamal = text "(forbidden) Elgamal" + pretty DH = text "DH" + 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 + toFFlag :: Int -> a + +data KSPFlag = NoModify + | KSPOther Int + deriving (Data, Generic, Show, Typeable) + +instance Eq KSPFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord KSPFlag where + compare = comparing fromFFlag + +instance FutureFlag KSPFlag where + fromFFlag NoModify = 0 + fromFFlag (KSPOther i) = fromIntegral i + + toFFlag 0 = NoModify + toFFlag i = KSPOther (fromIntegral i) + +instance Hashable KSPFlag + +instance Pretty KSPFlag where + pretty NoModify = text "no-modify" + pretty (KSPOther o) = text "unknown keyserver preference flag type" <+> pretty o + +instance A.ToJSON KSPFlag +instance A.FromJSON KSPFlag + +data KeyFlag = GroupKey + | AuthKey + | SplitKey + | EncryptStorageKey + | EncryptCommunicationsKey + | SignDataKey + | CertifyKeysKey + | KFOther Int + deriving (Data, Generic, Show, Typeable) + +instance Eq KeyFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord KeyFlag where + compare = comparing fromFFlag + +instance FutureFlag KeyFlag where + fromFFlag GroupKey = 0 + fromFFlag AuthKey = 2 + fromFFlag SplitKey = 3 + fromFFlag EncryptStorageKey = 4 + fromFFlag EncryptCommunicationsKey = 5 + fromFFlag SignDataKey = 6 + fromFFlag CertifyKeysKey = 7 + fromFFlag (KFOther i) = fromIntegral i + + toFFlag 0 = GroupKey + toFFlag 2 = AuthKey + toFFlag 3 = SplitKey + toFFlag 4 = EncryptStorageKey + toFFlag 5 = EncryptCommunicationsKey + toFFlag 6 = SignDataKey + toFFlag 7 = CertifyKeysKey + toFFlag i = KFOther (fromIntegral i) + +instance Hashable KeyFlag + +instance Pretty KeyFlag where + pretty GroupKey = text "group" + pretty AuthKey = text "auth" + pretty SplitKey = text "split" + pretty EncryptStorageKey = text "encrypt-storage" + pretty EncryptCommunicationsKey = text "encrypt-communications" + pretty SignDataKey = text "sign-data" + pretty CertifyKeysKey = text "certify-keys" + 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 + deriving (Data, Generic, Show, Typeable) + +instance Eq RevocationClass where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord RevocationClass where + compare = comparing fromFFlag + +instance FutureFlag RevocationClass where + fromFFlag SensitiveRK = 1 + fromFFlag (RClOther i) = fromIntegral i + + toFFlag 1 = SensitiveRK + toFFlag i = RClOther (fromIntegral i) + +instance Hashable RevocationClass + +instance Pretty RevocationClass where + pretty SensitiveRK = text "sensitive" + pretty (RClOther o) = text "unknown revocation class" <+> pretty o + +instance A.ToJSON RevocationClass +instance A.FromJSON RevocationClass + +data RevocationCode = NoReason + | KeySuperseded + | KeyMaterialCompromised + | KeyRetiredAndNoLongerUsed + | UserIdInfoNoLongerValid + | RCoOther Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq RevocationCode where + (==) a b = fromFVal a == fromFVal b + +instance Ord RevocationCode where + compare = comparing fromFVal + +instance FutureVal RevocationCode where + fromFVal NoReason = 0 + fromFVal KeySuperseded = 1 + fromFVal KeyMaterialCompromised = 2 + fromFVal KeyRetiredAndNoLongerUsed = 3 + fromFVal UserIdInfoNoLongerValid = 32 + fromFVal (RCoOther o) = o + toFVal 0 = NoReason + toFVal 1 = KeySuperseded + toFVal 2 = KeyMaterialCompromised + toFVal 3 = KeyRetiredAndNoLongerUsed + toFVal 32 = UserIdInfoNoLongerValid + toFVal o = RCoOther o + +instance Hashable RevocationCode + +instance Pretty RevocationCode where + pretty NoReason = text "no reason" + pretty KeySuperseded = text "key superseded" + pretty KeyMaterialCompromised = text "key material compromised" + pretty KeyRetiredAndNoLongerUsed = text "key retired and no longer used" + pretty UserIdInfoNoLongerValid = text "user-ID info no longer valid" + pretty (RCoOther o) = text "unknown revocation code" <+> pretty o + +instance A.ToJSON RevocationCode +instance A.FromJSON RevocationCode + +data FeatureFlag = ModificationDetection + | FeatureOther Int + deriving (Data, Generic, Show, Typeable) + +instance Eq FeatureFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord FeatureFlag where + compare = comparing fromFFlag + +instance FutureFlag FeatureFlag where + fromFFlag ModificationDetection = 7 + fromFFlag (FeatureOther i) = fromIntegral i + + toFFlag 7 = ModificationDetection + toFFlag i = FeatureOther (fromIntegral i) + +instance Hashable FeatureFlag +instance Hashable a => Hashable (Set a) where + hashWithSalt salt = hashWithSalt salt . Set.toList + +instance Pretty FeatureFlag where + pretty ModificationDetection = text "modification-detection" + 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) + +instance Newtype MPI Integer where + pack = MPI + unpack (MPI o) = o + +instance Hashable MPI + +instance Pretty MPI where + 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) + | SigVOther Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable SignaturePayload + +instance Pretty SignaturePayload where + pretty (SigV3 st ts eoki pka ha w16 mpis) = text "signature v3" <> char ':' <+> pretty st <+> pretty ts <+> pretty eoki <+> pretty pka <+> pretty ha <+> pretty w16 <+> (prettyList . NE.toList) mpis + pretty (SigV4 st pka ha hsps usps w16 mpis) = text "signature v4" <> char ':' <+> pretty st <+> pretty pka <+> pretty ha <+> prettyList hsps <+> prettyList usps <+> pretty w16 <+> (prettyList . NE.toList) mpis + pretty (SigVOther t bs) = text "unknown signature v" <> pretty t <> char ':' <+> pretty (BL.unpack bs) + +instance A.ToJSON SignaturePayload where + toJSON (SigV3 st ts eoki pka ha w16 mpis) = A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis) + toJSON (SigV4 st pka ha hsps usps w16 mpis) = A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis) + toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs) + +data KeyVersion = DeprecatedV3 | V4 + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable KeyVersion + +instance Pretty KeyVersion where + pretty DeprecatedV3 = text "(deprecated) v3" + pretty V4 = text "v4" + +instance A.ToJSON KeyVersion +instance A.FromJSON KeyVersion + +data PKPayload = PKPayload { + _keyVersion :: KeyVersion + , _timestamp :: ThirtyTwoBitTimeStamp + , _v3exp :: V3Expiration + , _pkalgo :: PubKeyAlgorithm + , _pubkey :: PKey + } deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord PKPayload where + compare = comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> comparing _pkalgo <> comparing _pubkey + +instance Hashable PKPayload + +instance Pretty PKPayload where + pretty (PKPayload kv ts v3e pka p) = pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p + +instance A.ToJSON PKPayload + +newtype IV = IV {unIV :: B.ByteString} + deriving (Byteable, ByteArrayAccess, Data, Eq, Generic, Hashable, Monoid, Show, Typeable) + +instance Newtype IV B.ByteString where + pack = IV + unpack (IV o) = o + +instance Pretty IV where + pretty = pretty . unpack + +instance A.ToJSON IV where + toJSON = A.toJSON . show . unpack + +data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString + | SUSSHA1 SymmetricAlgorithm S2K IV ByteString + | SUSym SymmetricAlgorithm IV ByteString + | SUUnencrypted SKey Word16 + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord SKAddendum where + compare a b = show a `compare` show b -- FIXME: this is ridiculous + +instance Hashable SKAddendum + +instance Pretty SKAddendum where + pretty (SUS16bit sa s2k iv bs) = text "SUS16bit" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty bs + pretty (SUSSHA1 sa s2k iv bs) = text "SUSSHA1" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty bs + pretty (SUSym sa iv bs) = text "SUSym" <+> pretty sa <+> pretty iv <+> pretty bs + pretty (SUUnencrypted s ck) = text "SUUnencrypted" <+> pretty s <+> pretty ck + +instance A.ToJSON SKAddendum where + toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) + toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) + toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs) + toJSON (SUUnencrypted s ck) = A.toJSON (s, ck) + +data DataType = BinaryData + | TextData + | UTF8Data + | OtherData Word8 + deriving (Show, Data, Generic, Typeable) + +instance Hashable DataType + +instance Eq DataType where + (==) a b = fromFVal a == fromFVal b + +instance Ord DataType where + compare = comparing fromFVal + +instance FutureVal DataType where + fromFVal BinaryData = fromIntegral . fromEnum $ 'b' + fromFVal TextData = fromIntegral . fromEnum $ 't' + fromFVal UTF8Data = fromIntegral . fromEnum $ 'u' + fromFVal (OtherData o) = o + + toFVal 0x62 = BinaryData + toFVal 0x74 = TextData + toFVal 0x75 = UTF8Data + toFVal o = OtherData o + +instance Pretty DataType where + pretty BinaryData = text "binary" + pretty TextData = text "text" + pretty UTF8Data = text "UTF-8" + 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) + +instance Newtype Salt B.ByteString where + pack = Salt + unpack (Salt o) = o + +instance Pretty Salt where + pretty = pretty . unpack + +instance A.ToJSON Salt where + toJSON = A.toJSON . show . unpack + +newtype IterationCount = IterationCount {unIterationCount :: Int} + deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable) + +instance Newtype IterationCount Int where + pack = IterationCount + unpack (IterationCount o) = o + +instance Pretty IterationCount where + pretty = pretty . unpack + +instance A.ToJSON IterationCount +instance A.FromJSON IterationCount + +data S2K = Simple HashAlgorithm + | Salted HashAlgorithm Salt + | IteratedSalted HashAlgorithm Salt IterationCount + | OtherS2K Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable S2K + +instance Pretty S2K where + pretty (Simple ha) = text "simple S2K," <+> pretty ha + pretty (Salted ha salt) = text "simple S2K," <+> pretty ha <+> pretty salt + pretty (IteratedSalted ha salt icount) = text "simple S2K," <+> pretty ha <+> pretty salt <+> pretty icount + pretty (OtherS2K t bs) = text "unknown S2K type" <+> pretty t <+> pretty bs + +instance A.ToJSON S2K where + toJSON (Simple ha) = A.toJSON ha + toJSON (Salted ha salt) = A.toJSON (ha, salt) + toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount) + toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs) + +data UserAttrSubPacket = ImageAttribute ImageHeader ImageData + | OtherUASub Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable UserAttrSubPacket + +instance Ord UserAttrSubPacket where + compare (ImageAttribute h1 d1) (ImageAttribute h2 d2) = compare h1 h2 <> compare d1 d2 + compare (ImageAttribute _ _) (OtherUASub _ _) = LT + compare (OtherUASub _ _) (ImageAttribute _ _) = GT + compare (OtherUASub t1 b1) (OtherUASub t2 b2) = compare t1 t2 <> compare b1 b2 + +instance Pretty UserAttrSubPacket where + pretty (ImageAttribute ih d) = text "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) + pretty (OtherUASub t bs) = text "unknown attribute type" <> (text . show) t <+> pretty (BL.unpack bs) + +instance A.ToJSON UserAttrSubPacket where + toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) + toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) + +data ImageHeader = ImageHV1 ImageFormat + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord ImageHeader where + compare (ImageHV1 a) (ImageHV1 b) = compare a b + +instance Hashable ImageHeader + +instance Pretty ImageHeader where + pretty (ImageHV1 f) = text "imghdr v1" <+> pretty f + +instance A.ToJSON ImageHeader +instance A.FromJSON ImageHeader + +data ImageFormat = JPEG + | OtherImage Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq ImageFormat where + (==) a b = fromFVal a == fromFVal b + +instance Ord ImageFormat where + compare = comparing fromFVal + +instance FutureVal ImageFormat where + fromFVal JPEG = 1 + fromFVal (OtherImage o) = o + + toFVal 1 = JPEG + toFVal o = OtherImage o + +instance Hashable ImageFormat + +instance Pretty ImageFormat where + pretty JPEG = text "JPEG" + pretty (OtherImage o) = text "unknown image format" <+> pretty o + +instance A.ToJSON ImageFormat +instance A.FromJSON ImageFormat + +data SigType = BinarySig + | CanonicalTextSig + | StandaloneSig + | GenericCert + | PersonaCert + | CasualCert + | PositiveCert + | SubkeyBindingSig + | PrimaryKeyBindingSig + | SignatureDirectlyOnAKey + | KeyRevocationSig + | SubkeyRevocationSig + | CertRevocationSig + | TimestampSig + | ThirdPartyConfirmationSig + | OtherSig Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq SigType where + (==) a b = fromFVal a == fromFVal b + +instance Ord SigType where + compare = comparing fromFVal + +instance FutureVal SigType where + fromFVal BinarySig = 0x00 + fromFVal CanonicalTextSig = 0x01 + fromFVal StandaloneSig = 0x02 + fromFVal GenericCert = 0x10 + fromFVal PersonaCert = 0x11 + fromFVal CasualCert = 0x12 + fromFVal PositiveCert = 0x13 + fromFVal SubkeyBindingSig = 0x18 + fromFVal PrimaryKeyBindingSig = 0x19 + fromFVal SignatureDirectlyOnAKey = 0x1F + fromFVal KeyRevocationSig = 0x20 + fromFVal SubkeyRevocationSig = 0x28 + fromFVal CertRevocationSig = 0x30 + fromFVal TimestampSig = 0x40 + fromFVal ThirdPartyConfirmationSig = 0x50 + fromFVal (OtherSig o) = o + + toFVal 0x00 = BinarySig + toFVal 0x01 = CanonicalTextSig + toFVal 0x02 = StandaloneSig + toFVal 0x10 = GenericCert + toFVal 0x11 = PersonaCert + toFVal 0x12 = CasualCert + toFVal 0x13 = PositiveCert + toFVal 0x18 = SubkeyBindingSig + toFVal 0x19 = PrimaryKeyBindingSig + toFVal 0x1F = SignatureDirectlyOnAKey + toFVal 0x20 = KeyRevocationSig + toFVal 0x28 = SubkeyRevocationSig + toFVal 0x30 = CertRevocationSig + toFVal 0x40 = TimestampSig + toFVal 0x50 = ThirdPartyConfirmationSig + toFVal o = OtherSig o + +instance Hashable SigType + +instance Pretty SigType where + pretty BinarySig = text "binary" + pretty CanonicalTextSig = text "canonical-text" + pretty StandaloneSig = text "standalone" + pretty GenericCert = text "generic" + pretty PersonaCert = text "persona" + pretty CasualCert = text "casual" + pretty PositiveCert = text "positive" + pretty SubkeyBindingSig = text "subkey-binding" + pretty PrimaryKeyBindingSig = text "primary-key-binding" + pretty SignatureDirectlyOnAKey = text "signature directly on a key" + pretty KeyRevocationSig = text "key-revocation" + pretty SubkeyRevocationSig = text "subkey-revocation" + pretty CertRevocationSig = text "cert-revocation" + pretty TimestampSig = text "timestamp" + pretty ThirdPartyConfirmationSig = text "third-party-confirmation" + 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) +instance Ord DSA_PublicKey +instance A.ToJSON DSA_PublicKey where + toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y) +instance Pretty DSA_PublicKey where + pretty (DSA_PublicKey (DSA.PublicKey p y)) = pretty (DSA_Params p) <+> pretty y +newtype RSA_PublicKey = RSA_PublicKey {unRSA_PublicKey :: RSA.PublicKey} + deriving (Data, Eq, Generic, Show, Typeable) +instance Ord RSA_PublicKey +instance A.ToJSON RSA_PublicKey where + toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e) +instance Pretty RSA_PublicKey where + pretty (RSA_PublicKey (RSA.PublicKey size n e)) = pretty size <+> pretty n <+> pretty e +newtype ECDSA_PublicKey = ECDSA_PublicKey {unECDSA_PublicKey :: ECDSA.PublicKey} + deriving (Data, Eq, Generic, Show, Typeable) +instance Ord ECDSA_PublicKey +instance A.ToJSON ECDSA_PublicKey where + toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = A.toJSON (show curve, show q) +instance Pretty ECDSA_PublicKey where + pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = pretty (show curve, show q) +newtype DSA_PrivateKey = DSA_PrivateKey {unDSA_PrivateKey :: DSA.PrivateKey} + deriving (Data, Eq, Generic, Show, Typeable) +instance Ord DSA_PrivateKey +instance A.ToJSON DSA_PrivateKey where + toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x) +instance Pretty DSA_PrivateKey where + pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x) +newtype RSA_PrivateKey = RSA_PrivateKey {unRSA_PrivateKey :: RSA.PrivateKey} + deriving (Data, Eq, Generic, Show, Typeable) +instance Ord RSA_PrivateKey +instance A.ToJSON RSA_PrivateKey where + toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv) +instance Pretty RSA_PrivateKey where + pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = pretty (RSA_PublicKey pub) <+> tupled (map pretty [d, p, q, dP, dQ, qinv]) +newtype ECDSA_PrivateKey = ECDSA_PrivateKey {unECDSA_PrivateKey :: ECDSA.PrivateKey} + deriving (Data, Eq, Generic, Show, Typeable) +instance Ord ECDSA_PrivateKey +instance A.ToJSON ECDSA_PrivateKey where + toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = A.toJSON (show curve, show d) +instance Pretty ECDSA_PrivateKey where + pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = pretty (show curve, show d) + +newtype DSA_Params = DSA_Params {unDSA_Params :: DSA.Params} + deriving (Data, Eq, Generic, Show, Typeable) +instance A.ToJSON DSA_Params where + toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q) +instance Pretty DSA_Params where + pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q) +instance Hashable DSA_Params where + hashWithSalt s (DSA_Params (DSA.Params p g q)) = s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q +instance Hashable DSA_PublicKey where + hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) = s `hashWithSalt` DSA_Params p `hashWithSalt` y +instance Hashable DSA_PrivateKey where + hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) = s `hashWithSalt` DSA_Params p `hashWithSalt` x +instance Hashable RSA_PublicKey where + hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) = s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e +instance Hashable RSA_PrivateKey where + hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = s `hashWithSalt` RSA_PublicKey pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt` q `hashWithSalt` dP `hashWithSalt` dQ `hashWithSalt` qinv +instance Hashable ECDSA_PublicKey where + hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = s `hashWithSalt` show curve `hashWithSalt` show q -- FIXME: don't use show +instance Hashable ECDSA_PrivateKey where + hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = s `hashWithSalt` show curve `hashWithSalt` show d -- FIXME: don't use show + +data ECCCurve = BrokenNISTP256 + | BrokenNISTP384 + | BrokenNISTP521 + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable ECCCurve + +data PKey = RSAPubKey RSA_PublicKey + | DSAPubKey DSA_PublicKey + | ElGamalPubKey [Integer] + | ECDHPubKey ECDSA_PublicKey HashAlgorithm SymmetricAlgorithm + | ECDSAPubKey ECDSA_PublicKey + | UnknownPKey ByteString + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable PKey + +instance Pretty PKey where + pretty (RSAPubKey p) = text "RSA" <+> pretty p + pretty (DSAPubKey p) = text "DSA" <+> pretty p + pretty (ElGamalPubKey p) = text "Elgamal" <+> pretty p + pretty (ECDHPubKey p ha sa) = text "ECDH" <+> pretty p <+> pretty ha <+> pretty sa + pretty (ECDSAPubKey p) = text "ECDSA" <+> pretty p + pretty (UnknownPKey bs) = text "unknown" <+> pretty bs + +instance A.ToJSON PKey where + toJSON (RSAPubKey p) = A.toJSON p + toJSON (DSAPubKey p) = A.toJSON p + toJSON (ElGamalPubKey p) = A.toJSON p + toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa) + toJSON (ECDSAPubKey p) = A.toJSON p + toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs) + +data SKey = RSAPrivateKey RSA_PrivateKey + | DSAPrivateKey DSA_PrivateKey + | ElGamalPrivateKey [Integer] + | ECDHPrivateKey ECDSA_PrivateKey + | ECDSAPrivateKey ECDSA_PrivateKey + | UnknownSKey ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable SKey + +instance Pretty SKey where + pretty (RSAPrivateKey p) = text "RSA" <+> pretty p + pretty (DSAPrivateKey p) = text "DSA" <+> pretty p + pretty (ElGamalPrivateKey p) = text "Elgamal" <+> pretty p + pretty (ECDHPrivateKey p) = text "ECDH" <+> pretty p + pretty (ECDSAPrivateKey p) = text "ECDSA" <+> pretty p + pretty (UnknownSKey bs) = text "unknown" <+> pretty bs + +instance A.ToJSON SKey where + toJSON (RSAPrivateKey k) = A.toJSON k + toJSON (DSAPrivateKey k) = A.toJSON k + toJSON (ElGamalPrivateKey k) = A.toJSON k + toJSON (ECDHPrivateKey k) = A.toJSON k + toJSON (ECDSAPrivateKey k) = A.toJSON k + toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs) + +newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance + deriving (Show, Eq) + +newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Newtype EightOctetKeyId ByteString where + pack = EightOctetKeyId + unpack (EightOctetKeyId o) = o + +instance Pretty EightOctetKeyId where + pretty = text . w8sToHex . BL.unpack . unpack + +-- FIXME: read-show +instance Read EightOctetKeyId where + readsPrec _ = map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s + +instance Hashable EightOctetKeyId + +instance A.ToJSON EightOctetKeyId where + 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) + +instance Newtype TwentyOctetFingerprint ByteString where + pack = TwentyOctetFingerprint + unpack (TwentyOctetFingerprint o) = o + +-- FIXME: read-show +instance Read TwentyOctetFingerprint where + readsPrec _ = map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ') + +instance Hashable TwentyOctetFingerprint + +instance Pretty TwentyOctetFingerprint where + pretty = text . take 40 . w8sToHex . BL.unpack . unTOF + +instance A.ToJSON TwentyOctetFingerprint where + 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 } + +instance Newtype SpacedFingerprint TwentyOctetFingerprint where + pack = SpacedFingerprint + unpack (SpacedFingerprint o) = o + +instance Pretty SpacedFingerprint where + pretty = hsep . punctuate space . map hsep . chunksOf 5 . map text . chunksOf 4 . take 40 . w8sToHex . BL.unpack . unTOF . unpack + +w8sToHex :: [Word8] -> String +w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "") + +hexToW8s :: ReadS Word8 +hexToW8s = concatMap readHex . chunksOf 2 . map toLower + +data TK = TK { + _tkKey :: (PKPayload, Maybe SKAddendum) + , _tkRevs :: [SignaturePayload] + , _tkUIDs :: [(Text, [SignaturePayload])] + , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] + , _tkSubs :: [(Pkt, [SignaturePayload])] + } deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord TK where + compare = comparing _tkKey -- FIXME: is this ridiculous? + +instance A.ToJSON TK + +type KeyringIxs = '[EightOctetKeyId, TwentyOctetFingerprint, Text] +type Keyring = IxSet KeyringIxs TK + +-- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a +data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI) + | SignaturePkt SignaturePayload + | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString) + | OnePassSignaturePkt PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag + | SecretKeyPkt PKPayload SKAddendum + | PublicKeyPkt PKPayload + | SecretSubkeyPkt PKPayload SKAddendum + | CompressedDataPkt CompressionAlgorithm CompressedDataPayload + | SymEncDataPkt ByteString + | MarkerPkt ByteString + | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString + | TrustPkt ByteString + | UserIdPkt Text + | PublicSubkeyPkt PKPayload + | UserAttributePkt [UserAttrSubPacket] + | SymEncIntegrityProtectedDataPkt PacketVersion ByteString + | ModificationDetectionCodePkt ByteString + | OtherPacketPkt Word8 ByteString + | BrokenPacketPkt String Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME + +instance Hashable Pkt + +instance Ord Pkt where + compare = comparing pktTag <> comparing hash -- FIXME: is there something saner? + +instance Pretty Pkt where + pretty (PKESKPkt pv eoki pka mpis) = text "PKESK v" <> (text . show) pv <> char ':' <+> pretty eoki <+> pretty pka <+> (prettyList . NE.toList) mpis + pretty (SignaturePkt sp) = pretty sp + pretty (SKESKPkt pv sa s2k mbs) = text "SKESK v" <> (text . show) pv <> char ':' <+> pretty sa <+> pretty s2k <+> pretty mbs + pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = text "one-pass signature v" <> (text . show) pv <> char ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag + pretty (SecretKeyPkt pkp ska) = text "secret key:" <+> pretty pkp <+> pretty ska + pretty (PublicKeyPkt pkp) = text "public key:" <+> pretty pkp + pretty (SecretSubkeyPkt pkp ska) = text "secret subkey:" <+> pretty pkp <+> pretty ska + pretty (CompressedDataPkt ca cdp) = text "compressed-data:" <+> pretty ca <+> pretty cdp + pretty (SymEncDataPkt bs) = text "symmetrically-encrypted-data:" <+> pretty bs + pretty (MarkerPkt bs) = text "marker:" <+> pretty bs + pretty (LiteralDataPkt dt fn ts bs) = text "literal-data" <+> pretty dt <+> pretty fn <+> pretty ts <+> pretty bs + pretty (TrustPkt bs) = text "trust:" <+> pretty (BL.unpack bs) + pretty (UserIdPkt u) = text "user-ID:" <+> pretty u + pretty (PublicSubkeyPkt pkp) = text "public subkey:" <+> pretty pkp + pretty (UserAttributePkt us) = text "user-attribute:" <+> prettyList us + pretty (SymEncIntegrityProtectedDataPkt pv bs) = text "symmetrically-encrypted-integrity-protected-data v" <> (text . show) pv <> char ':' <+> pretty bs + pretty (ModificationDetectionCodePkt bs) = text "MDC:" <+> pretty bs + pretty (OtherPacketPkt t bs) = text "unknown packet type" <+> pretty t <> char ':' <+> pretty bs + pretty (BrokenPacketPkt s t bs) = text "BROKEN packet (" <> pretty s <> char ')' <+> pretty t <> char ':' <+> pretty bs + +instance A.ToJSON Pkt where + toJSON (PKESKPkt pv eoki pka mpis) = object [T.pack "pkesk" .= object [T.pack "version" .= pv, T.pack "keyid" .= eoki, T.pack "pkalgo" .= pka, T.pack "mpis" .= NE.toList mpis]] + toJSON (SignaturePkt sp) = object [T.pack "signature" .= sp] + toJSON (SKESKPkt pv sa s2k mbs) = object [T.pack "skesk" .= object [T.pack "version" .= pv, T.pack "symalgo" .= sa, T.pack "s2k" .= s2k, T.pack "data" .= maybe mempty BL.unpack mbs]] + toJSON (OnePassSignaturePkt pv st ha pka eoki nestedflag) = object [T.pack "onepasssignature" .= object [T.pack "version" .= pv, T.pack "sigtype" .= st, T.pack "hashalgo" .= ha, T.pack "pkalgo" .= pka, T.pack "keyid" .= eoki, T.pack "nested" .= nestedflag]] + toJSON (SecretKeyPkt pkp ska) = object [T.pack "secretkey" .= object [T.pack "public" .= pkp, T.pack "secret" .= ska]] + toJSON (PublicKeyPkt pkp) = object [T.pack "publickey" .= pkp] + toJSON (SecretSubkeyPkt pkp ska) = object [T.pack "secretsubkey" .= object [T.pack "public" .= pkp, T.pack "secret" .= ska]] + toJSON (CompressedDataPkt ca cdp) = object [T.pack "compresseddata" .= object [T.pack "compressionalgo" .= ca, T.pack "data" .= BL.unpack cdp]] + toJSON (SymEncDataPkt bs) = object [T.pack "symencdata" .= BL.unpack bs] + toJSON (MarkerPkt bs) = object [T.pack "marker" .= BL.unpack bs] + toJSON (LiteralDataPkt dt fn ts bs) = object [T.pack "literaldata" .= object [T.pack "dt" .= dt, T.pack "filename" .= BL.unpack fn, T.pack "ts" .= ts, T.pack "data" .= BL.unpack bs]] + toJSON (TrustPkt bs) = object [T.pack "trust" .= BL.unpack bs] + toJSON (UserIdPkt u) = object [T.pack "userid" .= u] + toJSON (PublicSubkeyPkt pkp) = object [T.pack "publicsubkkey" .= pkp] + toJSON (UserAttributePkt us) = object [T.pack "userattribute" .= us] + toJSON (SymEncIntegrityProtectedDataPkt pv bs) = object [T.pack "symencipd" .= object [T.pack "version" .= pv, T.pack "data" .= BL.unpack bs]] + toJSON (ModificationDetectionCodePkt bs) = object [T.pack "mdc" .= BL.unpack bs] + toJSON (OtherPacketPkt t bs) = object [T.pack "otherpacket" .= object [T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]] + toJSON (BrokenPacketPkt s t bs) = object [T.pack "brokenpacket" .= object [T.pack "error" .= s, T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]] + +pktTag :: Pkt -> Word8 +pktTag (PKESKPkt {}) = 1 +pktTag (SignaturePkt _) = 2 +pktTag (SKESKPkt {}) = 3 +pktTag (OnePassSignaturePkt {}) = 4 +pktTag (SecretKeyPkt {}) = 5 +pktTag (PublicKeyPkt _) = 6 +pktTag (SecretSubkeyPkt {}) = 7 +pktTag (CompressedDataPkt {}) = 8 +pktTag (SymEncDataPkt _) = 9 +pktTag (MarkerPkt _) = 10 +pktTag (LiteralDataPkt {}) = 11 +pktTag (TrustPkt _) = 12 +pktTag (UserIdPkt _) = 13 +pktTag (PublicSubkeyPkt _) = 14 +pktTag (UserAttributePkt _) = 17 +pktTag (SymEncIntegrityProtectedDataPkt {}) = 18 +pktTag (ModificationDetectionCodePkt _) = 19 +pktTag (OtherPacketPkt t _) = t +pktTag (BrokenPacketPkt _ t _) = t -- is this the right thing to do? + +data Verification = Verification { + _verificationSigner :: PKPayload + , _verificationSignature :: SignaturePayload + } + +$(makeLenses ''TK) +$(makeLenses ''Verification) +$(makeLenses ''SigSubPacket) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs @@ -0,0 +1,341 @@ +-- PacketClass.hs: OpenPGP (RFC4880) data types +-- Copyright © 2012-2016 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Codec.Encryption.OpenPGP.Types.Internal.PacketClass where + +import Codec.Encryption.OpenPGP.Types.Internal.Base + +import Control.Lens (makeLenses) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Text.PrettyPrint.Free (Pretty(..)) + +class Packet a where + data PacketType a :: * + packetType :: a -> PacketType a + packetCode :: PacketType a -> Word8 + toPkt :: a -> Pkt + fromPkt :: Pkt -> a + +data PKESK = PKESK + { _pkeskPacketVersion :: PacketVersion + , _pkeskEightOctetKeyId :: EightOctetKeyId + , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm + , _pkeskMPIs :: NonEmpty MPI + } deriving (Data, Eq, Show, Typeable) +instance Packet PKESK where + data PacketType PKESK = PKESKType deriving (Show, Eq) + packetType _ = PKESKType + 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 + +data Signature = Signature -- FIXME? + { _signaturePayload :: SignaturePayload + } deriving (Data, Eq, Show, Typeable) +instance Packet Signature where + data PacketType Signature = SignatureType deriving (Show, Eq) + packetType _ = SignatureType + packetCode _ = 2 + toPkt (Signature a) = SignaturePkt a + fromPkt (SignaturePkt a) = Signature a + fromPkt _ = error "Cannot coerce non-Signature packet" + +instance Pretty Signature where + pretty = pretty . toPkt + +data SKESK = SKESK + { _skeskPacketVersion :: PacketVersion + , _skeskSymmetricAlgorithm :: SymmetricAlgorithm + , _skeskS2K :: S2K + , _skeskESK :: Maybe BL.ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet SKESK where + data PacketType SKESK = SKESKType deriving (Show, Eq) + packetType _ = SKESKType + 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 + +data OnePassSignature = OnePassSignature + { _onePassSignaturePacketVersion :: PacketVersion + , _onePassSignatureSigType :: SigType + , _onePassSignatureHashAlgorithm :: HashAlgorithm + , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm + , _onePassSignatureEightOctetKeyId :: EightOctetKeyId + , _onePassSignatureNestedFlag :: NestedFlag + } deriving (Data, Eq, Show, Typeable) +instance Packet OnePassSignature where + data PacketType OnePassSignature = OnePassSignatureType deriving (Show, Eq) + packetType _ = OnePassSignatureType + 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 + +data SecretKey = SecretKey + { _secretKeyPKPayload :: PKPayload + , _secretKeySKAddendum :: SKAddendum + } deriving (Data, Eq, Show, Typeable) +instance Packet SecretKey where + data PacketType SecretKey = SecretKeyType deriving (Show, Eq) + packetType _ = SecretKeyType + 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 + +data PublicKey = PublicKey + { _publicKeyPKPayload :: PKPayload + } deriving (Data, Eq, Show, Typeable) +instance Packet PublicKey where + data PacketType PublicKey = PublicKeyType deriving (Show, Eq) + packetType _ = PublicKeyType + 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 + +data SecretSubkey = SecretSubkey + { _secretSubkeyPKPayload :: PKPayload + , _secretSubkeySKAddendum :: SKAddendum + } deriving (Data, Eq, Show, Typeable) +instance Packet SecretSubkey where + data PacketType SecretSubkey = SecretSubkeyType deriving (Show, Eq) + packetType _ = SecretSubkeyType + 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 + +data CompressedData = CompressedData + { _compressedDataCompressionAlgorithm :: CompressionAlgorithm + , _compressedDataPayload :: CompressedDataPayload + } deriving (Data, Eq, Show, Typeable) +instance Packet CompressedData where + data PacketType CompressedData = CompressedDataType deriving (Show, Eq) + packetType _ = CompressedDataType + 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 + +data SymEncData = SymEncData + { _symEncDataPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet SymEncData where + data PacketType SymEncData = SymEncDataType deriving (Show, Eq) + packetType _ = SymEncDataType + 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 + +data Marker = Marker + { _markerPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet Marker where + data PacketType Marker = MarkerType deriving (Show, Eq) + packetType _ = MarkerType + 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 + +data LiteralData = LiteralData + { _literalDataDataType :: DataType + , _literalDataFileName :: FileName + , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp + , _literalDataPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet LiteralData where + data PacketType LiteralData = LiteralDataType deriving (Show, Eq) + packetType _ = LiteralDataType + 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 + +data Trust = Trust + { _trustPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet Trust where + data PacketType Trust = TrustType deriving (Show, Eq) + packetType _ = TrustType + 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 + +data UserId = UserId + { _userIdPayload :: Text + } deriving (Data, Eq, Show, Typeable) +instance Packet UserId where + data PacketType UserId = UserIdType deriving (Show, Eq) + packetType _ = UserIdType + 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 + +data PublicSubkey = PublicSubkey + { _publicSubkeyPKPayload :: PKPayload + } deriving (Data, Eq, Show, Typeable) +instance Packet PublicSubkey where + data PacketType PublicSubkey = PublicSubkeyType deriving (Show, Eq) + packetType _ = PublicSubkeyType + 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 + +data UserAttribute = UserAttribute + { _userAttributeSubPackets :: [UserAttrSubPacket] + } deriving (Data, Eq, Show, Typeable) +instance Packet UserAttribute where + data PacketType UserAttribute = UserAttributeType deriving (Show, Eq) + packetType _ = UserAttributeType + 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 + +data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData + { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion + , _symEncIntegrityProtectedDataPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet SymEncIntegrityProtectedData where + data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType deriving (Show, Eq) + packetType _ = SymEncIntegrityProtectedDataType + 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 + +data ModificationDetectionCode = ModificationDetectionCode + { _modificationDetectionCodePayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet ModificationDetectionCode where + data PacketType ModificationDetectionCode = ModificationDetectionCodeType deriving (Show, Eq) + packetType _ = ModificationDetectionCodeType + 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 + +data OtherPacket = OtherPacket + { _otherPacketType :: Word8 + , _otherPacketPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet OtherPacket where + data PacketType OtherPacket = OtherPacketType deriving (Show, Eq) + packetType _ = OtherPacketType + 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 + +data BrokenPacket = BrokenPacket + { _brokenPacketParseError :: String + , _brokenPacketType :: Word8 + , _brokenPacketPayload :: ByteString + } deriving (Data, Eq, Show, Typeable) +instance Packet BrokenPacket where + data PacketType BrokenPacket = BrokenPacketType deriving (Show, Eq) + packetType _ = BrokenPacketType + 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 + +$(makeLenses ''PKESK) +$(makeLenses ''Signature) +$(makeLenses ''SKESK) +$(makeLenses ''OnePassSignature) +$(makeLenses ''SecretKey) +$(makeLenses ''PKPayload) +$(makeLenses ''PublicKey) +$(makeLenses ''SecretSubkey) +$(makeLenses ''CompressedData) +$(makeLenses ''SymEncData) +$(makeLenses ''Marker) +$(makeLenses ''LiteralData) +$(makeLenses ''Trust) +$(makeLenses ''UserId) +$(makeLenses ''PublicSubkey) +$(makeLenses ''UserAttribute) +$(makeLenses ''SymEncIntegrityProtectedData) +$(makeLenses ''ModificationDetectionCode) +$(makeLenses ''OtherPacket) +$(makeLenses ''BrokenPacket) diff --git a/bench/mark.hs b/bench/mark.hs --- a/bench/mark.hs +++ b/bench/mark.hs @@ -19,12 +19,6 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -loadKeys fp = runResourceT $ CB.sourceFile fp DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume -loadKeyring fp = runResourceT $ CB.sourceFile fp DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap - -selfVerifyKeys fp = fmap (\ks -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) (loadKeys fp) -selfVerifyKeyring fp = fmap (\kr -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing) (IxSet.toList kr)) (loadKeyring fp) - main :: IO () main = defaultMain [ bgroup "keyring" [ bench "load keys" $ whnfIO (loadKeys "tests/data/debian-keyring.gpg") @@ -33,3 +27,9 @@ , bench "self-verify keyring" $ whnfIO (selfVerifyKeyring "tests/data/debian-keyring.gpg") ] ] + where + loadKeys fp = runResourceT $ CB.sourceFile fp DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume + loadKeyring fp = runResourceT $ CB.sourceFile fp DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap + + selfVerifyKeys fp = fmap (\ks -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) (loadKeys fp) + selfVerifyKeyring fp = fmap (\kr -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing) (IxSet.toList kr)) (loadKeyring fp) diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,7 +1,7 @@ Name: hOpenPGP -Version: 2.4.1 +Version: 2.4.2 Synopsis: native Haskell implementation of OpenPGP (RFC4880) -Description: native Haskell implementation of OpenPGP (RFC4880) +Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581) Homepage: http://floss.scru.org/hOpenPGP/ License: MIT License-file: LICENSE @@ -133,6 +133,10 @@ , tests/data/encryption-sym-3des-mdc.gpg , tests/data/encryption-sym-cast5.gpg , tests/data/encryption-sym-cast5-s2k0.gpg + , tests/data/encryption-sym-camellia128.gpg + , tests/data/encryption-sym-camellia128-s2k0.gpg + , tests/data/encryption-sym-camellia192.gpg + , tests/data/encryption-sym-camellia256.gpg , tests/data/16bitcksum.seckey , tests/data/aes256-sha512.seckey , tests/data/unencrypted.seckey @@ -173,6 +177,8 @@ , Codec.Encryption.OpenPGP.Internal.Cryptonite , Codec.Encryption.OpenPGP.Internal.HOBlockCipher , Codec.Encryption.OpenPGP.SerializeForSigs + , Codec.Encryption.OpenPGP.Types.Internal.Base + , Codec.Encryption.OpenPGP.Types.Internal.PacketClass , Codec.Encryption.OpenPGP.BlockCipher Build-depends: aeson , attoparsec @@ -325,4 +331,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v2.4.1 + tag: v2.4.2 diff --git a/tests/data/encryption-sym-camellia128-s2k0.gpg b/tests/data/encryption-sym-camellia128-s2k0.gpg new file mode 100644 Binary files /dev/null and b/tests/data/encryption-sym-camellia128-s2k0.gpg differ diff --git a/tests/data/encryption-sym-camellia128.gpg b/tests/data/encryption-sym-camellia128.gpg new file mode 100644 --- /dev/null +++ b/tests/data/encryption-sym-camellia128.gpg @@ -0,0 +1,2 @@ +Œ   +ƒe°×Þ*ü`Ò>Öz¬6Å­ý­ûÔ0²¸ðž_¿Có$ÐÊÚ:8·‘ÈR»A5¢8ùžTMý¯ÛGµéè˜ó¡ßN¯9л diff --git a/tests/data/encryption-sym-camellia192.gpg b/tests/data/encryption-sym-camellia192.gpg new file mode 100644 --- /dev/null +++ b/tests/data/encryption-sym-camellia192.gpg @@ -0,0 +1,3 @@ +Œ   +ßüfŠºS `Ò>új1ZÁHW{þ1³Ò¾‚ðĽŠFA$ÅÛýr2q °´¾‡l1+Gð¬SçCÐY0ÏÀt +÷3Fwi: diff --git a/tests/data/encryption-sym-camellia256.gpg b/tests/data/encryption-sym-camellia256.gpg new file mode 100644 Binary files /dev/null and b/tests/data/encryption-sym-camellia256.gpg differ diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -335,6 +335,10 @@ , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption simple Camellia128" (testSymmetricEncryption "encryption-sym-camellia128-s2k0.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted Camellia128" (testSymmetricEncryption "encryption-sym-camellia128.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted Camellia192" (testSymmetricEncryption "encryption-sym-camellia192.gpg" "symmetric-password.txt" "test\n") + , testCase "Symmetric Encryption iterated-salted Camellia256" (testSymmetricEncryption "encryption-sym-camellia256.gpg" "symmetric-password.txt" "test\n") ], testGroup "Encrypted secret keys" [ testCase "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "simple.seckey" "pki-password.txt")