Internal.hs

-- Internal.hs: private utility functions and such
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

module Codec.Encryption.OpenPGP.Internal
  ( countBits
  , PktStreamContext(..)
  , issuer
  , issuerFP
  , emptyPSC
  , leftPadTo
  , pubkeyToMPIs
  , multiplicativeInverse
  , curveoidBSToCurve
  , curveToCurveoidBS
  , point2MBS
  , curveoidBSToEdSigningCurve
  , edSigningCurveToCurveoidBS
  , curve2Curve
  , curveFromCurve
  ) where

import Crypto.Number.Serialize (i2osp, os2ip)
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 Data.Bits (testBit)
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.List (find)
import Data.Word (Word16, Word8)

import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime)
import Codec.Encryption.OpenPGP.Types

countBits :: ByteString -> Word16
countBits bs
  | BL.null bs = 0
  | otherwise =
    fromIntegral (BL.length bs * 8) - fromIntegral (go (BL.head bs) 7)
  where
    go :: Word8 -> Int -> Word8
    go _ 0 = 7
    go n b =
      if testBit n b
        then 7 - fromIntegral b
        else go n (b - 1)

data PktStreamContext =
  PktStreamContext
    { lastLD :: Pkt
    , lastUIDorUAt :: Pkt
    , lastSig :: Pkt
    , lastPrimaryKey :: Pkt
    , lastSubkey :: Pkt
    }

emptyPSC :: PktStreamContext
emptyPSC =
  PktStreamContext
    (OtherPacketPkt 0 "lastLD placeholder")
    (OtherPacketPkt 0 "lastUIDorUAt placeholder")
    (OtherPacketPkt 0 "lastSig placeholder")
    (OtherPacketPkt 0 "lastPrimaryKey placeholder")
    (OtherPacketPkt 0 "lastSubkey placeholder")

leftPadTo :: Int -> B.ByteString -> B.ByteString
leftPadTo targetLen bs
  | B.length bs >= targetLen = bs
  | otherwise = B.replicate (targetLen - B.length bs) 0 <> bs

issuer :: Pkt -> Maybe EightOctetKeyId
issuer pkt =
  case fromPktIssuerExtractionCase pkt of
    Just extractionCase ->
      find isIssuerSSP (unhashedSubpackets extractionCase) >>= issuerFromSubpacket
    Nothing -> Nothing

issuerFP :: Pkt -> Maybe Fingerprint
issuerFP pkt =
  case fromPktIssuerExtractionCase pkt of
    Just extractionCase ->
      find
        (isIssuerFingerprintFor (issuerFingerprintVersion extractionCase))
        (hashedSubpackets extractionCase) >>=
      issuerFingerprintFromSubpacket
    Nothing -> Nothing

data IssuerExtractionCase where
  IssuerExtractionCaseV4 :: SignaturePayloadV 'SigPayloadV4 -> IssuerExtractionCase
  IssuerExtractionCaseV6 :: SignaturePayloadV 'SigPayloadV6 -> IssuerExtractionCase

fromPktIssuerExtractionCase :: Pkt -> Maybe IssuerExtractionCase
fromPktIssuerExtractionCase pkt =
  case fromPktEitherSomeSignatureV pkt of
    Right (SomeSignatureV (SignatureV4Packet payload)) ->
      Just (IssuerExtractionCaseV4 payload)
    Right (SomeSignatureV (SignatureV6Packet payload)) ->
      Just (IssuerExtractionCaseV6 payload)
    _ -> Nothing

hashedSubpackets :: IssuerExtractionCase -> [SigSubPacket]
hashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) = hsubs
hashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ hsubs _ _ _)) = hsubs

unhashedSubpackets :: IssuerExtractionCase -> [SigSubPacket]
unhashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ _ usubs _ _)) = usubs
unhashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ _ usubs _ _)) = usubs

issuerFingerprintVersion :: IssuerExtractionCase -> IssuerFingerprintVersion
issuerFingerprintVersion IssuerExtractionCaseV4 {} = IssuerFingerprintV4
issuerFingerprintVersion IssuerExtractionCaseV6 {} = IssuerFingerprintV6

isIssuerFingerprintFor :: IssuerFingerprintVersion -> SigSubPacket -> Bool
isIssuerFingerprintFor version (SigSubPacket _ (IssuerFingerprint packetVersion _)) =
  packetVersion == version
isIssuerFingerprintFor _ _ = False

issuerFingerprintFromSubpacket :: SigSubPacket -> Maybe Fingerprint
issuerFingerprintFromSubpacket (SigSubPacket _ (IssuerFingerprint _ i)) = Just i
issuerFingerprintFromSubpacket _ = Nothing

issuerFromSubpacket :: SigSubPacket -> Maybe EightOctetKeyId
issuerFromSubpacket (SigSubPacket _ (Issuer i)) = Just i
issuerFromSubpacket _ = Nothing

pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) =
  [MPI (RSA.public_n k), MPI (RSA.public_e k)]
pubkeyToMPIs (DSAPubKey (DSA_PublicKey k)) =
  [ pkParams DSA.params_p
  , pkParams DSA.params_q
  , pkParams DSA.params_g
  , MPI . DSA.public_y $ k
  ]
  where
    pkParams f = MPI . f . DSA.public_params $ k
pubkeyToMPIs (ElGamalPubKey p g y) = [MPI p, MPI g, MPI y]
pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q))) _ _) =
  [MPI (os2ip (pointToBSOrError q))]
pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ ep) _ _) = [MPI (edPointInteger ep)]
pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q)))) =
  [MPI (os2ip (pointToBSOrError q))]
pubkeyToMPIs (EdDSAPubKey _ ep) = [MPI (edPointInteger ep)]

edPointInteger :: EdPoint -> Integer
edPointInteger (PrefixedNativeEPoint (EPoint x)) = x
edPointInteger (NativeEPoint (EPoint x)) = x

multiplicativeInverse :: Integral a => a -> a -> a
multiplicativeInverse _ 1 = 1
multiplicativeInverse q p = (n * q + 1) `div` p
  where
    n = p - multiplicativeInverse p (q `mod` p)

curveoidBSToCurve :: B.ByteString -> Either String ECCCurve
curveoidBSToCurve oidbs
  | B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] == oidbs =
    Right $ NISTP256 -- ECCT.getCurveByName ECCT.SEC_p256r1
  | B.pack [0x2B, 0x81, 0x04, 0x00, 0x22] == oidbs = Right $ NISTP384 -- ECCT.getCurveByName ECCT.SEC_p384r1
  | B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] == oidbs = Right $ NISTP521 -- ECCT.getCurveByName ECCT.SEC_p521r1
  | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] == oidbs =
    Right Curve25519
  | B.pack [0x2B, 0x65, 0x6F] == oidbs =
    Right Curve448
  | otherwise = Left $ concat ["unknown curve (...", show (B.unpack oidbs), ")"]

curveToCurveoidBS :: ECCCurve -> Either String B.ByteString
curveToCurveoidBS NISTP256 =
  Right $ B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07]
curveToCurveoidBS NISTP384 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x22]
curveToCurveoidBS NISTP521 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x23]
curveToCurveoidBS Curve25519 =
  Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01]
curveToCurveoidBS Curve448 = Right $ B.pack [0x2B, 0x65, 0x6F]
curveToCurveoidBS _ = Left "unknown curve"

point2MBS :: ECCT.PublicPoint -> Maybe B.ByteString
point2MBS (ECCT.Point x y)
  | B.null xb || B.null yb = Nothing
  | B.length xb /= B.length yb = Nothing
  | otherwise = Just (B.concat [B.singleton 0x04, xb, yb])
  where
    xb = i2osp x
    yb = i2osp y
point2MBS ECCT.PointO = Nothing

pointToBSOrError :: ECCT.PublicPoint -> B.ByteString
pointToBSOrError point =
  case point of
    ECCT.PointO -> error "OpenPGP forbids serializing the point at infinity"
    _ ->
      case point2MBS point of
        Just bs -> bs
        Nothing ->
          error
            "OpenPGP EC point serialization requires equal non-empty coordinate widths"

curveoidBSToEdSigningCurve :: B.ByteString -> Either String EdSigningCurve
curveoidBSToEdSigningCurve oidbs
  | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] == oidbs =
    Right Ed25519
  | B.pack [0x2B, 0x65, 0x71] == oidbs =
    Right Ed448
  | otherwise =
    Left $
    concat ["unknown Edwards signing curve (...", show (B.unpack oidbs), ")"]

edSigningCurveToCurveoidBS :: EdSigningCurve -> Either String B.ByteString
edSigningCurveToCurveoidBS Ed25519 =
  Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01]
edSigningCurveToCurveoidBS Ed448 = Right $ B.pack [0x2B, 0x65, 0x71]

curve2Curve :: ECCCurve -> ECCT.Curve
curve2Curve NISTP256 = ECCT.getCurveByName ECCT.SEC_p256r1
curve2Curve NISTP384 = ECCT.getCurveByName ECCT.SEC_p384r1
curve2Curve NISTP521 = ECCT.getCurveByName ECCT.SEC_p521r1

curveFromCurve :: ECCT.Curve -> ECCCurve
curveFromCurve c
  | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256
  | c == ECCT.getCurveByName ECCT.SEC_p384r1 = NISTP384
  | c == ECCT.getCurveByName ECCT.SEC_p521r1 = NISTP521