-- PKITypes.hs: OpenPGP (RFC4880) data types for public/secret keys
-- Copyright © 2012-2019  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

module Codec.Encryption.OpenPGP.Types.Internal.PKITypes where

import GHC.Generics (Generic)

import Codec.Encryption.OpenPGP.Types.Internal.Base
import Codec.Encryption.OpenPGP.Types.Internal.CryptoniteNewtypes

import qualified Data.Aeson as A
import qualified Data.Aeson.TH as ATH
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Data (Data)
import Data.Hashable (Hashable(..))
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Data.Text.Prettyprint.Doc (Pretty(..), (<+>))
import Data.Typeable (Typeable)
import Data.Word (Word16)

data EdSigningCurve =
  Ed25519
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Hashable EdSigningCurve

instance Pretty EdSigningCurve where
  pretty Ed25519 = pretty "Ed25519"

instance A.FromJSON EdSigningCurve

instance A.ToJSON EdSigningCurve

newtype EPoint =
  EPoint
    { unEPoint :: Integer
    }
  deriving (Data, Eq, Generic, Ord, Pretty, Show, Typeable)

instance Hashable EPoint

instance A.FromJSON EPoint

instance A.ToJSON EPoint

data PKey
  = RSAPubKey RSA_PublicKey
  | DSAPubKey DSA_PublicKey
  | ElGamalPubKey Integer Integer Integer
  | ECDHPubKey PKey HashAlgorithm SymmetricAlgorithm
  | ECDSAPubKey ECDSA_PublicKey
  | EdDSAPubKey EdSigningCurve EPoint
  | UnknownPKey ByteString
  deriving (Data, Eq, Generic, Ord, Show, Typeable)

instance Hashable PKey

instance Pretty PKey where
  pretty (RSAPubKey p) = pretty "RSA" <+> pretty p
  pretty (DSAPubKey p) = pretty "DSA" <+> pretty p
  pretty (ElGamalPubKey p g y) =
    pretty "Elgamal" <+> pretty p <+> pretty g <+> pretty y
  pretty (ECDHPubKey p ha sa) =
    pretty "ECDH" <+> pretty p <+> pretty ha <+> pretty sa
  pretty (ECDSAPubKey p) = pretty "ECDSA" <+> pretty p
  pretty (EdDSAPubKey c ep) = pretty c <+> pretty ep
  pretty (UnknownPKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs)

instance A.ToJSON PKey where
  toJSON (RSAPubKey p) = A.toJSON p
  toJSON (DSAPubKey p) = A.toJSON p
  toJSON (ElGamalPubKey p g y) = A.toJSON (p, g, y)
  toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa)
  toJSON (ECDSAPubKey p) = A.toJSON p
  toJSON (EdDSAPubKey c ep) = A.toJSON (c, ep)
  toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs)

data SKey
  = RSAPrivateKey RSA_PrivateKey
  | DSAPrivateKey DSA_PrivateKey
  | ElGamalPrivateKey Integer
  | ECDHPrivateKey ECDSA_PrivateKey
  | ECDSAPrivateKey ECDSA_PrivateKey
  | EdDSAPrivateKey EdSigningCurve B.ByteString
  | UnknownSKey ByteString
  deriving (Data, Eq, Generic, Show, Typeable)

instance Hashable SKey

instance Pretty SKey where
  pretty (RSAPrivateKey p) = pretty "RSA" <+> pretty p
  pretty (DSAPrivateKey p) = pretty "DSA" <+> pretty p
  pretty (ElGamalPrivateKey p) = pretty "Elgamal" <+> pretty p
  pretty (ECDHPrivateKey p) = pretty "ECDH" <+> pretty p
  pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p
  pretty (EdDSAPrivateKey c bs) =
    pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs))
  pretty (UnknownSKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper 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 (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs)
  toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs)

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

$(ATH.deriveToJSON ATH.defaultOptions ''PKPayload)

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) =
    pretty "SUS16bit" <+>
    pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs)
  pretty (SUSSHA1 sa s2k iv bs) =
    pretty "SUSSHA1" <+>
    pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs)
  pretty (SUSym sa iv bs) =
    pretty "SUSym" <+> pretty sa <+> pretty iv <+> pretty (bsToHexUpper bs)
  pretty (SUUnencrypted s ck) =
    pretty "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)