-- Base.hs: OpenPGP (RFC4880) data types
-- Copyright © 2012-2022  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)

import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS)
import Control.Applicative ((<|>))
import Control.Arrow ((***))
import Control.Lens (makeLenses, op, Wrapped)
import Control.Monad (mzero)
import Data.Aeson ((.=), object)
import qualified Data.Aeson as A
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as AK
#endif
import qualified Data.Aeson.TH as ATH
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16.Lazy as B16L
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (toLower, toUpper)
import Data.Data (Data)
import Data.Hashable (Hashable(..))
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.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.Time.Locale.Compat (defaultTimeLocale)
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32, Word8)
import Network.URI (URI(..), nullURI, parseURI, uriToString)
import Numeric (readHex)
import Prettyprinter (Pretty(..), (<+>), hsep, punctuate, space)

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

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

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

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 = pretty "plaintext"
  pretty IDEA = pretty "IDEA"
  pretty TripleDES = pretty "3DES"
  pretty CAST5 = pretty "CAST-128"
  pretty Blowfish = pretty "Blowfish"
  pretty ReservedSAFER = pretty "(reserved) SAFER"
  pretty ReservedDES = pretty "(reserved) DES"
  pretty AES128 = pretty "AES-128"
  pretty AES192 = pretty "AES-192"
  pretty AES256 = pretty "AES-256"
  pretty Twofish = pretty "Twofish"
  pretty Camellia128 = pretty "Camellia-128"
  pretty Camellia192 = pretty "Camellia-192"
  pretty Camellia256 = pretty "Camellia-256"
  pretty (OtherSA sa) = pretty "unknown symmetric algorithm" <+> pretty sa

$(ATH.deriveJSON ATH.defaultOptions ''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 = pretty "human-readable"
  pretty (OtherNF o) = pretty "unknown notation flag type" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''NotationFlag)

newtype ThirtyTwoBitTimeStamp =
  ThirtyTwoBitTimeStamp
    { unThirtyTwoBitTimeStamp :: Word32
    }
  deriving ( Bounded
           , Data
           , Enum
           , Eq
           , Generic
           , Hashable
           , Integral
           , Num
           , Ord
           , Real
           , Show
           , Typeable
           )

instance Wrapped ThirtyTwoBitTimeStamp

instance Pretty ThirtyTwoBitTimeStamp where
  pretty =
    pretty .
    formatTime defaultTimeLocale "%Y%m%d-%H%M%S" .
    posixSecondsToUTCTime . realToFrac

$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitTimeStamp)

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 ThirtyTwoBitDuration =
  ThirtyTwoBitDuration
    { unThirtyTwoBitDuration :: Word32
    }
  deriving ( Bounded
           , Data
           , Enum
           , Eq
           , Generic
           , Hashable
           , Integral
           , Num
           , Ord
           , Real
           , Show
           , Typeable
           )

instance Wrapped ThirtyTwoBitDuration

instance Pretty ThirtyTwoBitDuration where
  pretty = pretty . concat . unfoldr durU . op ThirtyTwoBitDuration

$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitDuration)

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 = pretty "sensitive"
  pretty (RClOther o) = pretty "unknown revocation class" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''RevocationClass)

data PubKeyAlgorithm
  = RSA
  | DeprecatedRSAEncryptOnly
  | DeprecatedRSASignOnly
  | ElgamalEncryptOnly
  | DSA
  | ECDH
  | ECDSA
  | ForbiddenElgamal
  | DH
  | EdDSA
  | 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 EdDSA = 22
  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 22 = EdDSA
  toFVal o = OtherPKA o

instance Hashable PubKeyAlgorithm

instance Pretty PubKeyAlgorithm where
  pretty RSA = pretty "RSA"
  pretty DeprecatedRSAEncryptOnly = pretty "(deprecated) RSA encrypt-only"
  pretty DeprecatedRSASignOnly = pretty "(deprecated) RSA sign-only"
  pretty ElgamalEncryptOnly = pretty "Elgamal encrypt-only"
  pretty DSA = pretty "DSA"
  pretty ECDH = pretty "ECDH"
  pretty ECDSA = pretty "ECDSA"
  pretty ForbiddenElgamal = pretty "(forbidden) Elgamal"
  pretty DH = pretty "DH"
  pretty EdDSA = pretty "EdDSA"
  pretty (OtherPKA pka) = pretty "unknown pubkey algorithm type" <+> pretty pka

$(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm)

newtype TwentyOctetFingerprint =
  TwentyOctetFingerprint
    { unTOF :: ByteString
    }
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Wrapped TwentyOctetFingerprint

-- 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 = pretty . take 40 . bsToHexUpper . unTOF

#if MIN_VERSION_aeson(2,0,0)
key :: String -> AK.Key
key = AK.fromText . T.pack
#else
key = T.pack
#endif

instance A.ToJSON TwentyOctetFingerprint where
  toJSON e = object [key "fpr" .= (A.toJSON . show . pretty) e]

instance A.FromJSON TwentyOctetFingerprint where
  parseJSON (A.Object v) = TwentyOctetFingerprint . read <$> v A..: key "fpr"
  parseJSON _ = mzero

newtype SpacedFingerprint =
  SpacedFingerprint
    { unSpacedFingerprint :: TwentyOctetFingerprint
    }
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Wrapped SpacedFingerprint

instance Pretty SpacedFingerprint where
  pretty =
    hsep .
    punctuate space .
    map hsep .
    chunksOf 5 .
    map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . op SpacedFingerprint

bsToHexUpper :: ByteString -> String
bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode

hexToW8s :: ReadS Word8
hexToW8s = concatMap readHex . chunksOf 2 . map toLower

newtype EightOctetKeyId =
  EightOctetKeyId
    { unEOKI :: ByteString
    }
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Wrapped EightOctetKeyId

instance Pretty EightOctetKeyId where
  pretty = pretty . bsToHexUpper . op EightOctetKeyId

-- 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 [key "eoki" .= (bsToHexUpper . op EightOctetKeyId) e]

instance A.FromJSON EightOctetKeyId where
  parseJSON (A.Object v) = EightOctetKeyId . read <$> v A..: key "eoki"
  parseJSON _ = mzero

newtype NotationName =
  NotationName
    { unNotationName :: ByteString
    }
  deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable)

instance Pretty NotationName where
  pretty = prettyLBS . unNotationName

instance Wrapped NotationName

instance A.ToJSON NotationName where
  toJSON nn = object [key "notationname" .= show (op NotationName nn)]

instance A.FromJSON NotationName where
  parseJSON (A.Object v) = NotationName . read <$> v A..: key "notationname"
  parseJSON _ = mzero

newtype NotationValue =
  NotationValue
    { unNotationValue :: ByteString
    }
  deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable)

instance Pretty NotationValue where
  pretty = prettyLBS . unNotationValue

instance Wrapped NotationValue

instance A.ToJSON NotationValue where
  toJSON nv = object [key "notationvalue" .= show (op NotationValue nv)]

instance A.FromJSON NotationValue where
  parseJSON (A.Object v) =
    NotationValue . read <$> v A..: key "notationvalue"
  parseJSON _ = mzero

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 = pretty "(deprecated) MD5"
  pretty SHA1 = pretty "SHA-1"
  pretty RIPEMD160 = pretty "RIPEMD-160"
  pretty SHA256 = pretty "SHA-256"
  pretty SHA384 = pretty "SHA-384"
  pretty SHA512 = pretty "SHA-512"
  pretty SHA224 = pretty "SHA-224"
  pretty (OtherHA ha) = pretty "unknown hash algorithm type" <+> pretty ha

$(ATH.deriveJSON ATH.defaultOptions ''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 = pretty "uncompressed"
  pretty ZIP = pretty "ZIP"
  pretty ZLIB = pretty "zlib"
  pretty BZip2 = pretty "bzip2"
  pretty (OtherCA ca) =
    pretty "unknown compression algorithm type" <+> pretty ca

$(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm)

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 = pretty "no-modify"
  pretty (KSPOther o) =
    pretty "unknown keyserver preference flag type" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''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 = pretty "group"
  pretty AuthKey = pretty "auth"
  pretty SplitKey = pretty "split"
  pretty EncryptStorageKey = pretty "encrypt-storage"
  pretty EncryptCommunicationsKey = pretty "encrypt-communications"
  pretty SignDataKey = pretty "sign-data"
  pretty CertifyKeysKey = pretty "certify-keys"
  pretty (KFOther o) = pretty "unknown key flag type" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''KeyFlag)

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 = pretty "no reason"
  pretty KeySuperseded = pretty "key superseded"
  pretty KeyMaterialCompromised = pretty "key material compromised"
  pretty KeyRetiredAndNoLongerUsed = pretty "key retired and no longer used"
  pretty UserIdInfoNoLongerValid = pretty "user-ID info no longer valid"
  pretty (RCoOther o) = pretty "unknown revocation code" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''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

#if !MIN_VERSION_hashable(1,3,4)
instance Hashable a => Hashable (Set a) where
  hashWithSalt salt = hashWithSalt salt . Set.toList
#endif

instance Pretty FeatureFlag where
  pretty ModificationDetection = pretty "modification-detection"
  pretty (FeatureOther o) = pretty "unknown feature flag type" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''FeatureFlag)

newtype URL =
  URL
    { unURL :: URI
    }
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Wrapped URL

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 "") . op URL

instance A.ToJSON URL where
  toJSON u = object [key "uri" .= (\uri -> uriToString id uri "") (op URL u)]

instance A.FromJSON URL where
  parseJSON (A.Object v) =
    URL . fromMaybe nullURI . parseURI <$> v A..: key "uri"
  parseJSON _ = mzero

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 = pretty "binary"
  pretty CanonicalTextSig = pretty "canonical-pretty"
  pretty StandaloneSig = pretty "standalone"
  pretty GenericCert = pretty "generic"
  pretty PersonaCert = pretty "persona"
  pretty CasualCert = pretty "casual"
  pretty PositiveCert = pretty "positive"
  pretty SubkeyBindingSig = pretty "subkey-binding"
  pretty PrimaryKeyBindingSig = pretty "primary-key-binding"
  pretty SignatureDirectlyOnAKey = pretty "signature directly on a key"
  pretty KeyRevocationSig = pretty "key-revocation"
  pretty SubkeyRevocationSig = pretty "subkey-revocation"
  pretty CertRevocationSig = pretty "cert-revocation"
  pretty TimestampSig = pretty "timestamp"
  pretty ThirdPartyConfirmationSig = pretty "third-party-confirmation"
  pretty (OtherSig o) = pretty "unknown signature type" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''SigType)

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

instance Wrapped MPI

instance Hashable MPI

instance Pretty MPI where
  pretty = pretty . op MPI

$(ATH.deriveJSON ATH.defaultOptions ''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) =
    pretty "signature v3" <> pretty ':' <+>
    pretty st <+>
    pretty ts <+>
    pretty eoki <+>
    pretty pka <+> pretty ha <+> pretty w16 <+> (pretty . NE.toList) mpis
  pretty (SigV4 st pka ha hsps usps w16 mpis) =
    pretty "signature v4" <> pretty ':' <+>
    pretty st <+>
    pretty pka <+>
    pretty ha <+>
    pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis
  pretty (SigVOther t bs) =
    pretty "unknown signature v" <> pretty t <> pretty ':' <+>
    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 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
  | IssuerFingerprint Word8 TwentyOctetFingerprint
  | UserDefinedSigSub Word8 ByteString
  | OtherSigSub Word8 ByteString
  deriving (Data, Eq, Generic, Show, Typeable) -- FIXME

instance Hashable SigSubPacketPayload

instance Pretty SigSubPacketPayload where
  pretty (SigCreationTime ts) = pretty "creation-time" <+> pretty ts
  pretty (SigExpirationTime d) = pretty "sig expiration time" <+> pretty d
  pretty (ExportableCertification e) =
    pretty "exportable certification" <+> pretty e
  pretty (TrustSignature tl ta) =
    pretty "trust signature" <+> pretty tl <+> pretty ta
  pretty (RegularExpression apdre) =
    pretty "regular expression" <+> prettyLBS apdre
  pretty (Revocable r) = pretty "revocable" <+> pretty r
  pretty (KeyExpirationTime d) = pretty "key expiration time" <+> pretty d
  pretty (PreferredSymmetricAlgorithms sas) =
    pretty "preferred symmetric algorithms" <+> pretty sas
  pretty (RevocationKey rcs pka tof) =
    pretty "revocation key" <+>
    pretty (Set.toList rcs) <+> pretty pka <+> pretty tof
  pretty (Issuer eoki) = pretty "issuer" <+> pretty eoki
  pretty (NotationData nfs nn nv) =
    pretty "notation data" <+>
    pretty (Set.toList nfs) <+> pretty nn <+> pretty nv
  pretty (PreferredHashAlgorithms phas) =
    pretty "preferred hash algorithms" <+> pretty phas
  pretty (PreferredCompressionAlgorithms pcas) =
    pretty "preferred compression algorithms" <+> pretty pcas
  pretty (KeyServerPreferences kspfs) =
    pretty "keyserver preferences" <+> pretty (Set.toList kspfs)
  pretty (PreferredKeyServer ks) = pretty "preferred keyserver" <+> prettyLBS ks
  pretty (PrimaryUserId p) =
    (if p
       then mempty
       else pretty "NOT ") <>
    pretty "primary user-ID"
  pretty (PolicyURL u) = pretty "policy URL" <+> pretty u
  pretty (KeyFlags kfs) = pretty "key flags" <+> pretty (Set.toList kfs)
  pretty (SignersUserId u) = pretty "signer's user-ID" <+> pretty u
  pretty (ReasonForRevocation rc rr) =
    pretty "reason for revocation" <+> pretty rc <+> pretty rr
  pretty (Features ffs) = pretty "features" <+> pretty (Set.toList ffs)
  pretty (SignatureTarget pka ha sh) =
    pretty "signature target" <+> pretty pka <+> pretty ha <+> prettyLBS sh
  pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp
  pretty (IssuerFingerprint kv ifp) =
    pretty "issuer fingerprint (v" <> pretty kv <> pretty ")" <+> pretty ifp
  pretty (UserDefinedSigSub t bs) =
    pretty "user-defined signature subpacket type" <+>
    pretty t <+> pretty (BL.unpack bs)
  pretty (OtherSigSub t bs) =
    pretty "unknown signature subpacket type" <+> pretty t <+> prettyLBS bs

instance A.ToJSON SigSubPacketPayload where
  toJSON (SigCreationTime ts) = object [key "sigCreationTime" .= ts]
  toJSON (SigExpirationTime d) = object [key "sigExpirationTime" .= d]
  toJSON (ExportableCertification e) =
    object [key "exportableCertification" .= e]
  toJSON (TrustSignature tl ta) = object [key "trustSignature" .= (tl, ta)]
  toJSON (RegularExpression apdre) =
    object [key "regularExpression" .= BL.unpack apdre]
  toJSON (Revocable r) = object [key "revocable" .= r]
  toJSON (KeyExpirationTime d) = object [key "keyExpirationTime" .= d]
  toJSON (PreferredSymmetricAlgorithms sas) =
    object [key "preferredSymmetricAlgorithms" .= sas]
  toJSON (RevocationKey rcs pka tof) =
    object [key "revocationKey" .= (rcs, pka, tof)]
  toJSON (Issuer eoki) = object [key "issuer" .= eoki]
  toJSON (NotationData nfs (NotationName nn) (NotationValue nv)) =
    object [key "notationData" .= (nfs, BL.unpack nn, BL.unpack nv)]
  toJSON (PreferredHashAlgorithms phas) =
    object [key "preferredHashAlgorithms" .= phas]
  toJSON (PreferredCompressionAlgorithms pcas) =
    object [key "preferredCompressionAlgorithms" .= pcas]
  toJSON (KeyServerPreferences kspfs) =
    object [key "keyServerPreferences" .= kspfs]
  toJSON (PreferredKeyServer ks) =
    object [key "preferredKeyServer" .= show ks]
  toJSON (PrimaryUserId p) = object [key "primaryUserId" .= p]
  toJSON (PolicyURL u) = object [key "policyURL" .= u]
  toJSON (KeyFlags kfs) = object [key "keyFlags" .= kfs]
  toJSON (SignersUserId u) = object [key "signersUserId" .= u]
  toJSON (ReasonForRevocation rc rr) =
    object [key "reasonForRevocation" .= (rc, rr)]
  toJSON (Features ffs) = object [key "features" .= ffs]
  toJSON (SignatureTarget pka ha sh) =
    object [key "signatureTarget" .= (pka, ha, BL.unpack sh)]
  toJSON (EmbeddedSignature sp) = object [key "embeddedSignature" .= sp]
  toJSON (IssuerFingerprint kv ifp) =
    object [key "issuerFingerprint" .= (kv, ifp)]
  toJSON (UserDefinedSigSub t bs) =
    object [key "userDefinedSigSub" .= (t, BL.unpack bs)]
  toJSON (OtherSigSub t bs) = object [key "otherSigSub" .= (t, BL.unpack bs)]

uc3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uc3 f ~(a, b, c) = f a b c

instance A.FromJSON SigSubPacketPayload where
  parseJSON (A.Object v) =
    (SigCreationTime <$> v A..: key "sigCreationTime") <|>
    (SigExpirationTime <$> v A..: key "sigExpirationTime") <|>
    (ExportableCertification <$> v A..: key "exportableCertification") <|>
    (uncurry TrustSignature <$> v A..: key "trustSignature") <|>
    (RegularExpression . BL.pack <$> v A..: key "regularExpression") <|>
    (Revocable <$> v A..: key "revocable") <|>
    (KeyExpirationTime <$> v A..: key "keyExpirationTime") <|>
    (PreferredSymmetricAlgorithms <$>
     v A..: key "preferredSymmetricAlgorithms") <|>
    (uc3 RevocationKey <$> v A..: key "revocationKey") <|>
    (Issuer <$> v A..: key "issuer") <|>
    (uc3 NotationData <$> v A..: key "notationData")
  parseJSON _ = mzero

data SigSubPacket =
  SigSubPacket
    { _sspCriticality :: Bool
    , _sspPayload :: SigSubPacketPayload
    }
  deriving (Data, Eq, Generic, Show, Typeable)

instance Pretty SigSubPacket where
  pretty x =
    (if _sspCriticality x
       then pretty '*'
       else mempty) <>
    (pretty . _sspPayload) x

instance Hashable SigSubPacket

instance A.ToJSON SigSubPacket
instance A.FromJSON SigSubPacket

$(makeLenses ''SigSubPacket)

data KeyVersion
  = DeprecatedV3
  | V4
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Hashable KeyVersion

instance Pretty KeyVersion where
  pretty DeprecatedV3 = pretty "(deprecated) v3"
  pretty V4 = pretty "v4"

$(ATH.deriveJSON ATH.defaultOptions ''KeyVersion)

newtype IV =
  IV
    { unIV :: B.ByteString
    }
  deriving ( ByteArrayAccess
           , Data
           , Eq
           , Generic
           , Hashable
           , Semigroup
           , Monoid
           , Show
           , Typeable
           )

instance Wrapped IV

instance Pretty IV where
  pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . op IV

instance A.ToJSON IV where
  toJSON = A.toJSON . show . op IV

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 = pretty "binary"
  pretty TextData = pretty "text"
  pretty UTF8Data = pretty "UTF-8"
  pretty (OtherData o) = pretty "other data type " <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''DataType)

newtype Salt =
  Salt
    { unSalt :: B.ByteString
    }
  deriving (Data, Eq, Generic, Hashable, Show, Typeable)

instance Wrapped Salt

instance Pretty Salt where
  pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . op Salt

instance A.ToJSON Salt where
  toJSON = A.toJSON . show . op Salt

newtype IterationCount =
  IterationCount
    { unIterationCount :: Int
    }
  deriving ( Bounded
           , Data
           , Enum
           , Eq
           , Generic
           , Hashable
           , Integral
           , Num
           , Ord
           , Real
           , Show
           , Typeable
           )

instance Wrapped IterationCount

instance Pretty IterationCount where
  pretty = pretty . op IterationCount

$(ATH.deriveJSON ATH.defaultOptions ''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) = pretty "simple S2K," <+> pretty ha
  pretty (Salted ha salt) = pretty "salted S2K," <+> pretty ha <+> pretty salt
  pretty (IteratedSalted ha salt icount) =
    pretty "iterated-salted S2K," <+>
    pretty ha <+> pretty salt <+> pretty icount
  pretty (OtherS2K t bs) =
    pretty "unknown S2K type" <+> pretty t <+> pretty (bsToHexUpper 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 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 = pretty "JPEG"
  pretty (OtherImage o) = pretty "unknown image format" <+> pretty o

$(ATH.deriveJSON ATH.defaultOptions ''ImageFormat)

newtype 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) = pretty "imghdr v1" <+> pretty f

$(ATH.deriveJSON ATH.defaultOptions ''ImageHeader)

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) =
    pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d)
  pretty (OtherUASub t bs) =
    pretty "unknown attribute type" <> pretty 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 ECCCurve
  = NISTP256
  | NISTP384
  | NISTP521
  | Curve25519
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Pretty ECCCurve where
  pretty NISTP256 = pretty "NIST P-256"
  pretty NISTP384 = pretty "NIST P-384"
  pretty NISTP521 = pretty "NIST P-521"
  pretty Curve25519 = pretty "Curve25519"

instance Hashable ECCCurve

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