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 AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Codec.Encryption.OpenPGP.Internal
    ( checksum16
    , checksum16BE
    , chunksOf8
    , curve2Curve
    , curveFromCurve
    , curveToCurveoidBS
    , curveoidBSToCurve
    , curveoidBSToEdSigningCurve
    , edPointBytes
    , edSigningCurveToCurveoidBS
    , emptyPSC
    , encodeWord64be
    , issuer
    , issuerFP
    , leftPadTo
    , PktStreamContext (..)
    , point2MBS
    , pubkeyToMPIs
    , xorBS
    -- Fixed-width byte arrays
    , FixedWidthBytes
    , byteWidth
    , intToFixedWidth
    , bsToFixedWidth
    , unSizedByteArray
    , putFixedWidthBytes
    , KnownNat
    ) 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 (Put, putByteString, putWord64be, runPut)
import Data.Bits (shiftR, xor, (.&.))
import Data.ByteArray.Sized
    ( SizedByteArray
    , sizedByteArray
    , unSizedByteArray
    )
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.List (find)
import Data.Proxy (Proxy (..))
import Data.Word (Word16, Word64)
import GHC.TypeLits (KnownNat, Nat, natVal)

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

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 -> Maybe B.ByteString
leftPadTo targetLen bs
    | B.length bs > targetLen = Nothing
    | otherwise =
        Just (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)

checksum16BE :: B.ByteString -> B.ByteString
checksum16BE 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

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) = do
    xb <- leftPadTo coordBytes (i2osp x)
    yb <- leftPadTo coordBytes (i2osp y)
    return $ B.concat [B.singleton 0x04, xb, yb]
  where
    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
-- FIXME: This is a band-aid
curve2Curve Curve25519 = noECDSACurve
curve2Curve Curve448 = noECDSACurve

{- | A deliberately degenerate ECDSA curve sentinel, used only as a placeholder
for the phantom curve parameter of an ECDSA.PrivateKey that wraps a scalar
for a non-ECDSA (EdDSA/X25519/X448) recipient. It is never used in any
computation. It is intentionally not any named curve (not a NIST curve, etc.)
so that it cannot be confused with a real curve.
-}
noECDSACurve :: ECCT.Curve
noECDSACurve =
    ECCT.CurveFP
        (ECCT.CurvePrime 0 (ECCT.CurveCommon 0 0 ECCT.PointO 0 0))

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)

-- | Fixed-width byte arrays with size known at compile time.
type FixedWidthBytes (n :: Nat) = SizedByteArray n ByteString

-- | Get the byte width of a @FixedWidthBytes n@ at runtime.
byteWidth :: forall n. KnownNat n => Int
byteWidth = fromIntegral (natVal (Proxy @n))

-- | Convert an 'Integer' to a 'FixedWidthBytes n', left-padding with zeros if needed.
intToFixedWidth
    :: forall n. KnownNat n => Integer -> Maybe (FixedWidthBytes n)
intToFixedWidth i = sizedByteArray =<< leftPadTo (byteWidth @n) (i2osp i)

-- | Convert a 'ByteString' to a 'FixedWidthBytes n', left-padding with zeros if needed.
bsToFixedWidth
    :: forall n. KnownNat n => ByteString -> Maybe (FixedWidthBytes n)
bsToFixedWidth bs = sizedByteArray =<< leftPadTo (byteWidth @n) bs

-- | Serialize a 'FixedWidthBytes n' using 'Put'.
putFixedWidthBytes :: FixedWidthBytes n -> Put
putFixedWidthBytes = putByteString . unSizedByteArray