-- CryptonNewtypes.hs: OpenPGP (RFC4880) newtype wrappers for some crypton types
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}

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

import GHC.Generics (Generic)

import Control.Monad (mzero)
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.Aeson as A
import Data.Data (Data)
import Data.Hashable (Hashable(..))
import Data.Typeable (Typeable)
import Prettyprinter (Pretty(..), (<+>), tupled)

newtype DSA_PublicKey =
  DSA_PublicKey
    { unDSA_PublicKey :: DSA.PublicKey
    }
  deriving (Data, Eq, Generic, Show, Typeable)

instance Ord DSA_PublicKey where
  compare (DSA_PublicKey (DSA.PublicKey p1 y1)) (DSA_PublicKey (DSA.PublicKey p2 y2)) =
    compare (DSA_Params p1) (DSA_Params p2) <> compare y1 y2

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 where
  compare (RSA_PublicKey (RSA.PublicKey size1 n1 e1)) (RSA_PublicKey (RSA.PublicKey size2 n2 e2)) =
    compare size1 size2 <> compare n1 n2 <> compare e1 e2

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 where
  compare (ECDSA_PublicKey (ECDSA.PublicKey curve1 q1)) (ECDSA_PublicKey (ECDSA.PublicKey curve2 q2)) =
    compareCurve curve1 curve2 <> compareECPoint q1 q2

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 where
  compare (DSA_PrivateKey (DSA.PrivateKey p1 x1)) (DSA_PrivateKey (DSA.PrivateKey p2 x2)) =
    compare (DSA_Params p1) (DSA_Params p2) <> compare x1 x2

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 where
  compare (RSA_PrivateKey (RSA.PrivateKey pub1 d1 p1 q1 dP1 dQ1 qinv1))
          (RSA_PrivateKey (RSA.PrivateKey pub2 d2 p2 q2 dP2 dQ2 qinv2)) =
    compare (RSA_PublicKey pub1) (RSA_PublicKey pub2) <>
    compare d1 d2 <> compare p1 p2 <> compare q1 q2 <>
    compare dP1 dP2 <> compare dQ1 dQ2 <> compare qinv1 qinv2

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 where
  compare (ECDSA_PrivateKey (ECDSA.PrivateKey curve1 d1)) (ECDSA_PrivateKey (ECDSA.PrivateKey curve2 d2)) =
    compareCurve curve1 curve2 <> compare d1 d2

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 Ord DSA_Params where
  compare (DSA_Params (DSA.Params p1 g1 q1)) (DSA_Params (DSA.Params p2 g2 q2)) =
    compare p1 p2 <> compare g1 g2 <> compare q1 q2

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)) =
    hashWithCurve s curve `hashWithECPoint` q

instance Hashable ECDSA_PrivateKey where
  hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =
    hashWithCurve s curve `hashWithSalt` d

-- Structural helpers for ECCT types that lack Hashable/Ord instances.

hashWithECPoint :: Int -> ECCT.Point -> Int
hashWithECPoint s ECCT.PointO         = s `hashWithSalt` (0 :: Int)
hashWithECPoint s (ECCT.Point x y)    = s `hashWithSalt` (1 :: Int) `hashWithSalt` x `hashWithSalt` y

hashWithCurveCommon :: Int -> ECCT.CurveCommon -> Int
hashWithCurveCommon s cc =
  hashWithECPoint
    (s `hashWithSalt` ECCT.ecc_a cc `hashWithSalt` ECCT.ecc_b cc)
    (ECCT.ecc_g cc)
    `hashWithSalt` ECCT.ecc_n cc `hashWithSalt` ECCT.ecc_h cc

hashWithCurve :: Int -> ECCT.Curve -> Int
hashWithCurve s (ECCT.CurveFP  (ECCT.CurvePrime  p   cc)) =
  hashWithCurveCommon (s `hashWithSalt` (0 :: Int) `hashWithSalt` p) cc
hashWithCurve s (ECCT.CurveF2m (ECCT.CurveBinary poly cc)) =
  hashWithCurveCommon (s `hashWithSalt` (1 :: Int) `hashWithSalt` poly) cc

compareECPoint :: ECCT.Point -> ECCT.Point -> Ordering
compareECPoint ECCT.PointO       ECCT.PointO       = EQ
compareECPoint ECCT.PointO       _                  = LT
compareECPoint _                  ECCT.PointO       = GT
compareECPoint (ECCT.Point x1 y1) (ECCT.Point x2 y2) =
  compare x1 x2 <> compare y1 y2

compareCurveCommon :: ECCT.CurveCommon -> ECCT.CurveCommon -> Ordering
compareCurveCommon cc1 cc2 =
  compare (ECCT.ecc_a cc1) (ECCT.ecc_a cc2) <>
  compare (ECCT.ecc_b cc1) (ECCT.ecc_b cc2) <>
  compareECPoint (ECCT.ecc_g cc1) (ECCT.ecc_g cc2) <>
  compare (ECCT.ecc_n cc1) (ECCT.ecc_n cc2) <>
  compare (ECCT.ecc_h cc1) (ECCT.ecc_h cc2)

compareCurve :: ECCT.Curve -> ECCT.Curve -> Ordering
compareCurve (ECCT.CurveFP  (ECCT.CurvePrime  p1   cc1)) (ECCT.CurveFP  (ECCT.CurvePrime  p2   cc2)) =
  compare p1 p2 <> compareCurveCommon cc1 cc2
compareCurve (ECCT.CurveF2m (ECCT.CurveBinary poly1 cc1)) (ECCT.CurveF2m (ECCT.CurveBinary poly2 cc2)) =
  compare poly1 poly2 <> compareCurveCommon cc1 cc2
compareCurve (ECCT.CurveFP  _) (ECCT.CurveF2m _) = LT
compareCurve (ECCT.CurveF2m _) (ECCT.CurveFP  _) = GT

newtype ECurvePoint =
  ECurvePoint
    { unECurvepoint :: ECCT.Point
    }
  deriving (Data, Eq, Generic, Show, Typeable)

instance A.ToJSON ECurvePoint where
  toJSON (ECurvePoint (ECCT.Point x y)) = A.toJSON (x, y)
  toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity"

instance A.FromJSON ECurvePoint where
  parseJSON v =
    case A.fromJSON v :: A.Result (Integer, Integer) of
      A.Success (x, y) -> pure (ECurvePoint (ECCT.Point x y))
      A.Error _ ->
        case A.fromJSON v :: A.Result String of
          A.Success "point at infinity" -> pure (ECurvePoint ECCT.PointO)
          _ -> mzero
