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
    ( checksum16
    , checksum16Bytes
    , chunksOf8
    , curve2Curve
    , curveFromCurve
    , curveToCurveoidBS
    , curveoidBSToCurve
    , curveoidBSToEdSigningCurve
    , edPointBytes
    , edSigningCurveToCurveoidBS
    , emptyPSC
    , encodeWord64be
    , issuer
    , issuerFP
    , leftPadTo
    , PktStreamContext (..)
    , point2MBS
    , pubkeyToMPIs
    , xorBS
    ) 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.Binary.Put (putWord64be, runPut)
import Data.Bits (shiftR, testBit, xor, (.&.))
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, Word64, Word8)

import Codec.Encryption.OpenPGP.Ontology
    ( isIssuerSSP
    )
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.Types.Internal.Errors
    ( CurveConversionError (..)
    , renderCurveConversionError
    )

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

checksum16 :: B.ByteString -> Word16
checksum16 =
    fromIntegral
        . B.foldl'
            (\acc octet -> (acc + fromIntegral octet) .&. (0xffff :: Int))
            (0 :: Int)

checksum16Bytes :: B.ByteString -> B.ByteString
checksum16Bytes bs = B.cons hi (B.singleton lo)
  where
    chk = checksum16 bs
    hi = fromIntegral (chk `shiftR` 8)
    lo = fromIntegral chk

edPointBytes :: EdPoint -> B.ByteString
edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x
edPointBytes (NativeEPoint (EPoint x)) = i2osp x

encodeWord64be :: Word64 -> B.ByteString
encodeWord64be = BL.toStrict . runPut . putWord64be

chunksOf8 :: B.ByteString -> [B.ByteString]
chunksOf8 bs
    | B.null bs = []
    | otherwise =
        let (h, t) = B.splitAt 8 bs
         in h : chunksOf8 t

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 curve q)))
            _
            _
        ) =
        [MPI (os2ip (pointToBSOrError curve q))]
pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ ep) _ _) = [MPI (edPointInteger ep)]
pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey curve q)))) =
    [MPI (os2ip (pointToBSOrError curve 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 CurveConversionError 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 (CurveConversionUnsupportedCurve oidbs)

curveToCurveoidBS
    :: ECCCurve -> Either CurveConversionError 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.Curve -> ECCT.PublicPoint -> Maybe B.ByteString
point2MBS curve (ECCT.Point x y) = Just $ B.concat [B.singleton 0x04, pad x, pad y]
  where
    pad n = leftPadTo coordBytes (i2osp n)
    coordBytes = (ECCT.curveSizeBits curve + 7) `div` 8
point2MBS _ ECCT.PointO = Nothing

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

curveoidBSToEdSigningCurve
    :: B.ByteString -> Either CurveConversionError 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 (CurveConversionUnsupportedEdCurve oidbs)

edSigningCurveToCurveoidBS
    :: EdSigningCurve -> Either CurveConversionError 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

xorBS :: B.ByteString -> B.ByteString -> B.ByteString
xorBS a b = B.pack (B.zipWith xor a b)