-- PKITypes.hs: OpenPGP (RFC4880) data types for public/secret keys
-- Copyright © 2012-2018  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 Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Data (Data)
import Data.Hashable (Hashable(..))
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Data.Typeable (Typeable)
import Data.Word (Word16)
import Data.Text.Prettyprint.Doc (Pretty(..), (<+>))

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)