-- Types.hs: OpenPGP (RFC4880) data types
-- Copyright © 2012  Clint Adams
-- This software is released under the terms of the ISC license.
-- (See the LICENSE file).

module Codec.Encryption.OpenPGP.Types (
   SigSubPacket(..)
 , CompressionAlgorithm(..)
 , HashAlgorithm(..)
 , PubKeyAlgorithm(..)
 , SymmetricAlgorithm(..)
 , MPI(..)
 , Packet(..)
 , S2K(..)
 , SignaturePayload(..)
 , UserAttrSubPacket(..)
 , SigType(..)
 , ImageHeader(..)
 , ImageFormat(..)
 , PKPayload(..)
 , SKAddendum(..)
 , DataType(..)
 , PKey(..)
 , SKey(..)
 , EightOctetKeyId(..)
 , TwentyOctetFingerprint(..)
 , TK(..)
 , FutureFlag
 , FutureVal
 , Keyring
 , fromFVal
 , fromFFlag
 , toFVal
 , toFFlag
 , Block(Block)
 , unBlock
) where

import qualified Crypto.Cipher.RSA as RSA
import qualified Crypto.Cipher.DSA as DSA

import Control.Arrow ((***))
import Data.ByteString (ByteString)
import Data.Char (toLower, toUpper)
import qualified Data.ByteString as B
import Data.List.Split (splitEvery)
import Data.Map (Map)
import Data.Set (Set)
import Data.Word (Word8, Word16, Word32)
import Numeric (readHex, showHex)

type TimeStamp = Word32
type Exportability = Bool
type TrustLevel = Word8
type TrustAmount = Word8
type AlmostPublicDomainRegex = ByteString
type Revocability = Bool
type RevocationReason = ByteString
type KeyServer = ByteString
type URL = ByteString
type NotationName = ByteString
type NotationValue = ByteString
type UserId = ByteString
type SignatureHash = ByteString
type PacketVersion = Word8
type Salt = ByteString
type Count = Int
type V3Expiration = Word16
type CompressedDataPayload = ByteString
type FileName = ByteString
type ImageData = ByteString
type NestedFlag = Bool
type IV = ByteString

data SymmetricAlgorithm = Plaintext
                        | IDEA
                        | TripleDES
                        | CAST5
                        | Blowfish
                        | ReservedSAFER
                        | ReservedDES
                        | AES128
                        | AES192
                        | AES256
                        | Twofish
                        | OtherSA Word8
     deriving (Show)

instance Eq SymmetricAlgorithm where
    (==) a b = fromFVal a == fromFVal b

instance Ord SymmetricAlgorithm where
    compare a b = fromFVal a `compare` fromFVal b

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

data NotationFlag = HumanReadable
                  | OtherNF Int
     deriving (Show)

instance Eq NotationFlag where
    (==) a b = fromFFlag a == fromFFlag b

instance Ord NotationFlag where
    compare a b = fromFFlag a `compare` fromFFlag b

instance FutureFlag NotationFlag where
    fromFFlag HumanReadable = 0
    fromFFlag (OtherNF o) = fromIntegral o

    toFFlag 0 = HumanReadable
    toFFlag o = OtherNF (fromIntegral o)

data SigSubPacket = SigCreationTime Bool TimeStamp
                  | SigExpirationTime Bool TimeStamp
                  | ExportableCertification Bool Exportability
                  | TrustSignature Bool TrustLevel TrustAmount
                  | RegularExpression Bool AlmostPublicDomainRegex
                  | Revocable Bool Revocability
                  | KeyExpirationTime Bool TimeStamp
                  | PreferredSymmetricAlgorithms Bool [SymmetricAlgorithm]
                  | RevocationKey Bool (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint
                  | Issuer Bool EightOctetKeyId
                  | NotationData Bool (Set NotationFlag) NotationName NotationValue
                  | PreferredHashAlgorithms Bool [HashAlgorithm]
                  | PreferredCompressionAlgorithms Bool [CompressionAlgorithm]
                  | KeyServerPreferences Bool (Set KSPFlag)
                  | PreferredKeyServer Bool KeyServer
                  | PrimaryUserId Bool Bool
                  | PolicyURL Bool URL
                  | KeyFlags Bool (Set KeyFlag)
                  | SignersUserId Bool UserId
                  | ReasonForRevocation Bool RevocationCode RevocationReason
                  | Features Bool (Set FeatureFlag)
                  | SignatureTarget Bool PubKeyAlgorithm HashAlgorithm SignatureHash
                  | EmbeddedSignature Bool SignaturePayload
                  | UserDefinedSigSub Bool Word8 ByteString
                  | OtherSigSub Bool Word8 ByteString
    deriving (Show, Eq) -- FIXME

data HashAlgorithm = DeprecatedMD5
                   | SHA1
                   | RIPEMD160
                   | SHA256
                   | SHA384
                   | SHA512
                   | SHA224
                   | OtherHA Word8
    deriving (Show)

instance Eq HashAlgorithm where
    (==) a b = fromFVal a == fromFVal b

instance Ord HashAlgorithm where
    compare a b = fromFVal a `compare` fromFVal b

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

data CompressionAlgorithm = Uncompressed
                          | ZIP
                          | ZLIB
                          | BZip2
                          | OtherCA Word8
    deriving (Show)

instance Eq CompressionAlgorithm where
    (==) a b = fromFVal a == fromFVal b

instance Ord CompressionAlgorithm where
    compare a b = fromFVal a `compare` fromFVal b

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

class (Eq a, Ord a) => FutureVal a where
   fromFVal :: a -> Word8
   toFVal :: Word8 -> a

data PubKeyAlgorithm = RSA
                     | RSAEncryptOnly
                     | RSASignOnly
                     | ElgamalEncryptOnly
                     | DSA
                     | EC
                     | ECDSA
                     | Elgamal
                     | DH
                     | OtherPKA Word8
    deriving (Show)

instance Eq PubKeyAlgorithm where
    (==) a b = fromFVal a == fromFVal b

instance Ord PubKeyAlgorithm where
    compare a b = fromFVal a `compare` fromFVal b

instance FutureVal PubKeyAlgorithm where
    fromFVal RSA = 1
    fromFVal RSAEncryptOnly = 2
    fromFVal RSASignOnly = 3
    fromFVal ElgamalEncryptOnly = 16
    fromFVal DSA = 17
    fromFVal EC = 18
    fromFVal ECDSA = 19
    fromFVal Elgamal = 20
    fromFVal DH = 21
    fromFVal (OtherPKA o) = o
    toFVal 1 = RSA
    toFVal 2 = RSAEncryptOnly
    toFVal 3 = RSASignOnly
    toFVal 16 = ElgamalEncryptOnly
    toFVal 17 = DSA
    toFVal 18 = EC
    toFVal 19 = ECDSA
    toFVal 20 = Elgamal
    toFVal 21 = DH
    toFVal o = OtherPKA o

class (Eq a, Ord a) => FutureFlag a where
    fromFFlag :: a -> Int
    toFFlag :: Int -> a

data KSPFlag = NoModify
             | KSPOther Int
    deriving (Show)

instance Eq KSPFlag where
    (==) a b = fromFFlag a == fromFFlag b

instance Ord KSPFlag where
    compare a b = fromFFlag a `compare` fromFFlag b

instance FutureFlag KSPFlag where
    fromFFlag NoModify = 0
    fromFFlag (KSPOther i) = fromIntegral i

    toFFlag 0 = NoModify
    toFFlag i = KSPOther (fromIntegral i)

data KeyFlag = GroupKey
             | AuthKey
             | SplitKey
             | EncryptStorageKey
             | EncryptCommunicationsKey
             | SignDataKey
             | CertifyKeysKey
             | KFOther Int
    deriving (Show)

instance Eq KeyFlag where
    (==) a b = fromFFlag a == fromFFlag b

instance Ord KeyFlag where
    compare a b = fromFFlag a `compare` fromFFlag b

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)

data RevocationClass = SensitiveRK
                     | RClOther Int
    deriving (Show)

instance Eq RevocationClass where
    (==) a b = fromFFlag a == fromFFlag b

instance Ord RevocationClass where
    compare a b = fromFFlag a `compare` fromFFlag b

instance FutureFlag RevocationClass where
    fromFFlag SensitiveRK = 1
    fromFFlag (RClOther i) = fromIntegral i

    toFFlag 1 = SensitiveRK
    toFFlag i = RClOther (fromIntegral i)

data RevocationCode = NoReason
                    | KeySuperseded
                    | KeyMaterialCompromised
                    | KeyRetiredAndNoLongerUsed
                    | UserIdInfoNoLongerValid
                    | RCoOther Word8
    deriving (Show)

instance Eq RevocationCode where
    (==) a b = fromFVal a == fromFVal b

instance Ord RevocationCode where
    compare a b = fromFVal a `compare` fromFVal b

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

data FeatureFlag = ModificationDetection
                 | FeatureOther Int
    deriving (Show)

instance Eq FeatureFlag where
    (==) a b = fromFFlag a == fromFFlag b

instance Ord FeatureFlag where
    compare a b = fromFFlag a `compare` fromFFlag b

instance FutureFlag FeatureFlag where
    fromFFlag ModificationDetection = 7
    fromFFlag (FeatureOther i) = fromIntegral i

    toFFlag 7 = ModificationDetection
    toFFlag i = FeatureOther (fromIntegral i)

newtype MPI = MPI {unMPI :: Integer}
    deriving (Show, Eq)

data SignaturePayload = SigV3 SigType Word32 EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 [MPI]
                      | SigV4 SigType PubKeyAlgorithm HashAlgorithm [SigSubPacket] [SigSubPacket] Word16 [MPI]
                      | SigVOther Word8 ByteString
    deriving (Show, Eq) -- FIXME

data PKPayload = PubV3 TimeStamp V3Expiration PubKeyAlgorithm PKey
               | PubV4 TimeStamp PubKeyAlgorithm PKey
    deriving (Show, Eq)

data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString
                | SUSSHA1 SymmetricAlgorithm S2K IV ByteString
                | SUSym SymmetricAlgorithm IV ByteString
                | SUUnencrypted SKey Word16
    deriving (Show, Eq)

data DataType = BinaryData
              | TextData
              | UTF8Data
              | OtherData Word8
    deriving (Show)

instance Eq DataType where
    (==) a b = fromFVal a == fromFVal b

instance Ord DataType where
    compare a b = fromFVal a `compare` fromFVal b

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

data Packet = PKESK PacketVersion EightOctetKeyId PubKeyAlgorithm [MPI]
            | Signature SignaturePayload
            | SKESK PacketVersion SymmetricAlgorithm S2K [MPI]
            | OnePassSignature PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag
            | SecretKey PKPayload SKAddendum
            | PublicKey PKPayload
            | SecretSubkey PKPayload SKAddendum
            | CompressedData CompressionAlgorithm CompressedDataPayload
            | SymEncData ByteString
            | Marker ByteString
            | LiteralData DataType FileName TimeStamp ByteString
            | Trust ByteString
            | UserId String
            | PublicSubkey PKPayload
            | UserAttribute [UserAttrSubPacket]
            | SymEncIntegrityProtectedData PacketVersion ByteString
            | ModificationDetectionCode ByteString
            | OtherPacket Word8 ByteString
    deriving (Show, Eq) -- FIXME

data S2K = Simple HashAlgorithm
         | Salted HashAlgorithm Salt
         | IteratedSalted HashAlgorithm Salt Count
         | OtherS2K Word8 ByteString
    deriving (Show, Eq) -- FIXME

data UserAttrSubPacket = ImageAttribute ImageHeader ImageData
                       | OtherUASub Word8 ByteString
    deriving (Show, Eq) -- FIXME

data ImageHeader = ImageHV1 ImageFormat
    deriving (Show, Eq)

data ImageFormat = JPEG
                 | OtherImage Word8
    deriving (Show)

instance Eq ImageFormat where
    (==) a b = fromFVal a == fromFVal b

instance Ord ImageFormat where
    compare a b = fromFVal a `compare` fromFVal b

instance FutureVal ImageFormat where
    fromFVal JPEG = 1
    fromFVal (OtherImage o) = o

    toFVal 1 = JPEG
    toFVal o = OtherImage o

data SigType = BinarySig
             | CanonicalTextSig
             | StandaloneSig
             | GenericCert
             | PersonaCert
             | CasualCert
             | PositiveCert
             | SubkeyBindingSig
             | PrimaryKeyBindingSig
             | SignatureDirectlyOnAKey
             | KeyRevocationSig
             | SubkeyRevocationSig
             | CertRevocationSig
             | TimestampSig
             | ThirdPartyConfirmationSig
             | OtherSig Word8
    deriving (Show)

instance Eq SigType where
    (==) a b = fromFVal a == fromFVal b

instance Ord SigType where
    compare a b = fromFVal a `compare` fromFVal b

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

data PKey = RSAPubKey RSA.PublicKey
          | DSAPubKey DSA.PublicKey
          | ElGamalPubKey [Integer]
    deriving (Show, Eq)

data SKey = RSAPrivateKey RSA.PrivateKey
          | DSAPrivateKey DSA.PrivateKey
          | ElGamalPrivateKey [Integer]
    deriving (Show, Eq)

newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance
    deriving (Show, Eq)

newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString}
    deriving (Eq, Ord) -- FIXME

instance Show EightOctetKeyId where
    show = w8sToHex . B.unpack . unEOKI

instance Read EightOctetKeyId where
    readsPrec _ = map ((EightOctetKeyId . B.pack *** concat) . unzip) . splitEvery 8 . hexToW8s

newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString}
    deriving (Eq)

instance Show TwentyOctetFingerprint where
    show = take 50 . concatMap (++" ") . concatMap (++[""]) . splitEvery 5 . splitEvery 4 . w8sToHex . B.unpack . unTOF

instance Read TwentyOctetFingerprint where
    readsPrec _ = map ((TwentyOctetFingerprint . B.pack *** concat) . unzip) . splitEvery 20 . hexToW8s . filter (/= ' ')

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 . splitEvery 2 . map toLower

data TK = TK {
    tkPKP :: PKPayload
  , tkmSKA :: (Maybe SKAddendum)
  , tkRevs :: [SignaturePayload]
  , tkUIDs :: [(String, [SignaturePayload])]
  , tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]
  , tkSubs :: [(Packet, SignaturePayload, Maybe SignaturePayload)]
  }
    deriving (Eq, Show)

instance Ord TK where
    compare a b = show a `compare` show b -- FIXME: this is ridiculous

type Keyring = Map EightOctetKeyId (Set TK)