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

module Codec.Encryption.OpenPGP.Internal
  ( countBits
  , PktStreamContext(..)
  , issuer
  , issuerFP
  , emptyPSC
  , pubkeyToMPIs
  , multiplicativeInverse
  , curveoidBSToCurve
  , curveToCurveoidBS
  , point2BS
  , 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, isIssuerFPSSP, isSigCreationTime)
import Codec.Encryption.OpenPGP.Types

countBits :: ByteString -> Word16
countBits :: ByteString -> Word16
countBits ByteString
bs
  | ByteString -> Bool
BL.null ByteString
bs = Word16
0
  | Bool
otherwise =
    Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
BL.length ByteString
bs Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
8) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int -> Word8
go (HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
bs) Int
7)
  where
    go :: Word8 -> Int -> Word8
    go :: Word8 -> Int -> Word8
go Word8
_ Int
0 = Word8
7
    go Word8
n Int
b =
      if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
b
        then Word8
7 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b
        else Word8 -> Int -> Word8
go Word8
n (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

emptyPSC :: PktStreamContext
emptyPSC :: PktStreamContext
emptyPSC =
  Pkt -> Pkt -> Pkt -> Pkt -> Pkt -> PktStreamContext
PktStreamContext
    (Word8 -> ByteString -> Pkt
OtherPacketPkt Word8
0 ByteString
"lastLD placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt Word8
0 ByteString
"lastUIDorUAt placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt Word8
0 ByteString
"lastSig placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt Word8
0 ByteString
"lastPrimaryKey placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt Word8
0 ByteString
"lastSubkey placeholder")

issuer :: Pkt -> Maybe EightOctetKeyId
issuer :: Pkt -> Maybe EightOctetKeyId
issuer (SignaturePkt (SigV4 SigType
_ PubKeyAlgorithm
_ HashAlgorithm
_ [SigSubPacket]
_ [SigSubPacket]
usubs Word16
_ NonEmpty MPI
_)) =
  (SigSubPacket -> EightOctetKeyId)
-> Maybe SigSubPacket -> Maybe EightOctetKeyId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SigSubPacket Bool
_ (Issuer EightOctetKeyId
i)) -> EightOctetKeyId
i) ((SigSubPacket -> Bool) -> [SigSubPacket] -> Maybe SigSubPacket
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find SigSubPacket -> Bool
isIssuerSSP [SigSubPacket]
usubs)
issuer Pkt
_ = Maybe EightOctetKeyId
forall a. Maybe a
Nothing

issuerFP :: Pkt -> Maybe TwentyOctetFingerprint
issuerFP :: Pkt -> Maybe TwentyOctetFingerprint
issuerFP (SignaturePkt (SigV4 SigType
_ PubKeyAlgorithm
_ HashAlgorithm
_ [SigSubPacket]
hsubs [SigSubPacket]
_ Word16
_ NonEmpty MPI
_)) =
  (SigSubPacket -> TwentyOctetFingerprint)
-> Maybe SigSubPacket -> Maybe TwentyOctetFingerprint
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SigSubPacket Bool
_ (IssuerFingerprint Word8
_ TwentyOctetFingerprint
i)) -> TwentyOctetFingerprint
i) ((SigSubPacket -> Bool) -> [SigSubPacket] -> Maybe SigSubPacket
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find SigSubPacket -> Bool
isIssuerFPSSP [SigSubPacket]
hsubs)
issuerFP Pkt
_ = Maybe TwentyOctetFingerprint
forall a. Maybe a
Nothing

pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs (RSAPubKey (RSA_PublicKey PublicKey
k)) =
  [Integer -> MPI
MPI (PublicKey -> Integer
RSA.public_n PublicKey
k), Integer -> MPI
MPI (PublicKey -> Integer
RSA.public_e PublicKey
k)]
pubkeyToMPIs (DSAPubKey (DSA_PublicKey PublicKey
k)) =
  [ (Params -> Integer) -> MPI
pkParams Params -> Integer
DSA.params_p
  , (Params -> Integer) -> MPI
pkParams Params -> Integer
DSA.params_q
  , (Params -> Integer) -> MPI
pkParams Params -> Integer
DSA.params_g
  , Integer -> MPI
MPI (Integer -> MPI) -> (PublicKey -> Integer) -> PublicKey -> MPI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> Integer
DSA.public_y (PublicKey -> MPI) -> PublicKey -> MPI
forall a b. (a -> b) -> a -> b
$ PublicKey
k
  ]
  where
    pkParams :: (Params -> Integer) -> MPI
pkParams Params -> Integer
f = Integer -> MPI
MPI (Integer -> MPI) -> (PublicKey -> Integer) -> PublicKey -> MPI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> Integer
f (Params -> Integer)
-> (PublicKey -> Params) -> PublicKey -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> Params
DSA.public_params (PublicKey -> MPI) -> PublicKey -> MPI
forall a b. (a -> b) -> a -> b
$ PublicKey
k
pubkeyToMPIs (ElGamalPubKey Integer
p Integer
g Integer
y) = [Integer -> MPI
MPI Integer
p, Integer -> MPI
MPI Integer
g, Integer -> MPI
MPI Integer
y]
pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey Curve
_ PublicPoint
q))) HashAlgorithm
_ SymmetricAlgorithm
_) =
  [Integer -> MPI
MPI (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (PublicPoint -> ByteString
point2BS PublicPoint
q))]
pubkeyToMPIs (ECDHPubKey (EdDSAPubKey EdSigningCurve
_ (EPoint Integer
x)) HashAlgorithm
_ SymmetricAlgorithm
_) = [Integer -> MPI
MPI Integer
x]
pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey Curve
_ PublicPoint
q)))) =
  [Integer -> MPI
MPI (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (PublicPoint -> ByteString
point2BS PublicPoint
q))]
pubkeyToMPIs (EdDSAPubKey EdSigningCurve
_ (EPoint Integer
x)) = [Integer -> MPI
MPI Integer
x]

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

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

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

point2BS :: ECCT.PublicPoint -> B.ByteString
point2BS :: PublicPoint -> ByteString
point2BS (ECCT.Point Integer
x Integer
y) = [ByteString] -> ByteString
B.concat [Word8 -> ByteString
B.singleton Word8
0x04, Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
x, Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp Integer
y] -- FIXME: check for length equality?
point2BS PublicPoint
ECCT.PointO = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"FIXME: point at infinity"

curveoidBSToEdSigningCurve :: B.ByteString -> Either String EdSigningCurve
curveoidBSToEdSigningCurve :: ByteString -> Either [Char] EdSigningCurve
curveoidBSToEdSigningCurve ByteString
oidbs
  | [Word8] -> ByteString
B.pack [Word8
0x2B, Word8
0x06, Word8
0x01, Word8
0x04, Word8
0x01, Word8
0xDA, Word8
0x47, Word8
0x0F, Word8
0x01] ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
oidbs =
    EdSigningCurve -> Either [Char] EdSigningCurve
forall a b. b -> Either a b
Right EdSigningCurve
Ed25519
  | Bool
otherwise =
    [Char] -> Either [Char] EdSigningCurve
forall a b. a -> Either a b
Left ([Char] -> Either [Char] EdSigningCurve)
-> [Char] -> Either [Char] EdSigningCurve
forall a b. (a -> b) -> a -> b
$
    [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"unknown Edwards signing curve (...", [Word8] -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> [Word8]
B.unpack ByteString
oidbs), [Char]
")"]

edSigningCurveToCurveoidBS :: EdSigningCurve -> Either String B.ByteString
edSigningCurveToCurveoidBS :: EdSigningCurve -> Either [Char] ByteString
edSigningCurveToCurveoidBS EdSigningCurve
Ed25519 =
  ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack [Word8
0x2B, Word8
0x06, Word8
0x01, Word8
0x04, Word8
0x01, Word8
0xDA, Word8
0x47, Word8
0x0F, Word8
0x01]

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

curveFromCurve :: ECCT.Curve -> ECCCurve
curveFromCurve :: Curve -> ECCCurve
curveFromCurve Curve
c
  | Curve
c Curve -> Curve -> Bool
forall a. Eq a => a -> a -> Bool
== CurveName -> Curve
ECCT.getCurveByName CurveName
ECCT.SEC_p256r1 = ECCCurve
NISTP256
  | Curve
c Curve -> Curve -> Bool
forall a. Eq a => a -> a -> Bool
== CurveName -> Curve
ECCT.getCurveByName CurveName
ECCT.SEC_p384r1 = ECCCurve
NISTP384
  | Curve
c Curve -> Curve -> Bool
forall a. Eq a => a -> a -> Bool
== CurveName -> Curve
ECCT.getCurveByName CurveName
ECCT.SEC_p521r1 = ECCCurve
NISTP521