-- 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 bs :: ByteString
bs
  | ByteString -> Bool
BL.null ByteString
bs = 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
* 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 (ByteString -> Word8
BL.head ByteString
bs) 7)
  where
    go :: Word8 -> Int -> Word8
    go :: Word8 -> Int -> Word8
go _ 0 = 7
    go n :: Word8
n b :: Int
b =
      if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
b
        then 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
- 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 0 "lastLD placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt 0 "lastUIDorUAt placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt 0 "lastSig placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt 0 "lastPrimaryKey placeholder")
    (Word8 -> ByteString -> Pkt
OtherPacketPkt 0 "lastSubkey placeholder")

issuer :: Pkt -> Maybe EightOctetKeyId
issuer :: Pkt -> Maybe EightOctetKeyId
issuer (SignaturePkt (SigV4 _ _ _ _ usubs :: [SigSubPacket]
usubs _ _)) =
  (SigSubPacket -> EightOctetKeyId)
-> Maybe SigSubPacket -> Maybe EightOctetKeyId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SigSubPacket _ (Issuer i :: 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 _ = Maybe EightOctetKeyId
forall a. Maybe a
Nothing

issuerFP :: Pkt -> Maybe TwentyOctetFingerprint
issuerFP :: Pkt -> Maybe TwentyOctetFingerprint
issuerFP (SignaturePkt (SigV4 _ _ _ hsubs :: [SigSubPacket]
hsubs _ _ _)) =
  (SigSubPacket -> TwentyOctetFingerprint)
-> Maybe SigSubPacket -> Maybe TwentyOctetFingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SigSubPacket _ (IssuerFingerprint _ i :: 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 _ = Maybe TwentyOctetFingerprint
forall a. Maybe a
Nothing

pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs (RSAPubKey (RSA_PublicKey k :: 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 k :: 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 f :: 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 p :: Integer
p g :: Integer
g y :: Integer
y) = [Integer -> MPI
MPI Integer
p, Integer -> MPI
MPI Integer
g, Integer -> MPI
MPI Integer
y]
pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q :: PublicPoint
q))) _ _) =
  [Integer -> MPI
MPI (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (PublicPoint -> ByteString
point2BS PublicPoint
q))]
pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ (EPoint x :: Integer
x)) _ _) = [Integer -> MPI
MPI Integer
x]
pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q :: PublicPoint
q)))) =
  [Integer -> MPI
MPI (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (PublicPoint -> ByteString
point2BS PublicPoint
q))]
pubkeyToMPIs (EdDSAPubKey _ (EPoint x :: Integer
x)) = [Integer -> MPI
MPI Integer
x]

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

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

point2BS :: ECCT.PublicPoint -> B.ByteString
point2BS :: PublicPoint -> ByteString
point2BS (ECCT.Point x :: Integer
x y :: Integer
y) = [ByteString] -> ByteString
B.concat [Word8 -> ByteString
B.singleton 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 ECCT.PointO = String -> ByteString
forall a. HasCallStack => String -> a
error "FIXME: point at infinity"

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

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

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

curveFromCurve :: ECCT.Curve -> ECCCurve
curveFromCurve :: Curve -> ECCCurve
curveFromCurve c :: 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