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]

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 EdSigningCurve25519
    | B.pack [0x2B, 0x65, 0x71] == oidbs =
        Right EdSigningCurve448
    | otherwise =
        Left $
            concat
                [ "unknown Edwards signing curve (..."
                , show (B.unpack oidbs)
                , ")"
                ]

edSigningCurveToCurveoidBS
    :: EdSigningCurve -> Either String B.ByteString
edSigningCurveToCurveoidBS EdSigningCurve25519 =
    Right $
        B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01]
edSigningCurveToCurveoidBS EdSigningCurve448 = 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