    -- Internal.hs: private utility functions and such
    -- Copyright © 2012-2016  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
     , emptyPSC
     , pubkeyToMPIs
     , multiplicativeInverse
     , sigType
     , sigPKA
     , sigHA
     , sigCT
     , truncatingVerify
    ) where

    import Crypto.Hash (hashWith)
    import qualified Crypto.Hash.IO as CHI
    import Crypto.Number.Basic (numBits)
    import Crypto.Number.ModArithmetic (expFast, inverse)
    import Crypto.Number.Serialize (os2ip)
    import qualified Crypto.PubKey.DSA as DSA
    import qualified Crypto.PubKey.RSA as RSA

    import Data.Bits (testBit)
    import Data.ByteArray (ByteArrayAccess)
    import qualified Data.ByteArray as BA
    import qualified Data.ByteString as B
    import Data.ByteString.Lazy (ByteString)
    import qualified Data.ByteString.Lazy as BL
    import Data.List (find)
    import Data.Maybe (fromJust)
    import Data.Word (Word8, Word16)

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

    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")

    issuer :: Pkt -> Maybe EightOctetKeyId
    issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs)
    issuer _ = 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]

    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)

    sigType :: SignaturePayload -> Maybe SigType
    sigType (SigV3 st _ _ _ _ _ _) = Just st
    sigType (SigV4 st _ _ _ _ _ _) = Just st
    sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild

    sigPKA :: SignaturePayload -> Maybe PubKeyAlgorithm
    sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka
    sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka
    sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild

    sigHA :: SignaturePayload -> Maybe HashAlgorithm
    sigHA (SigV3 _ _ _ _ ha _ _) = Just ha
    sigHA (SigV4 _ _ ha _ _ _ _) = Just ha
    sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild

    sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp
    sigCT (SigV3 _ ct _ _ _ _ _) = Just ct
    sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs)
    sigCT _ = Nothing

    truncatingVerify :: (ByteArrayAccess msg, CHI.HashAlgorithm hash) => hash -> DSA.PublicKey -> DSA.Signature -> msg -> Bool
    truncatingVerify hashAlg pk (DSA.Signature r s) m
        -- Reject the signature if either 0 < r < q or 0 < s < q is not satisfied.
        | r <= 0 || r >= q || s <= 0 || s >= q = False
        | otherwise                            = v == r
        where (DSA.Params p g q) = DSA.public_params pk
              y       = DSA.public_y pk
              hm      = os2ip . dsaTruncate . BA.convert $ hashWith hashAlg m

              w       = fromJust $ inverse s q
              u1      = (hm*w) `mod` q
              u2      = (r*w) `mod` q
              v       = (expFast g u1 p * expFast y u2 p) `mod` p `mod` q
              dsaTruncate bs = let lbs = BL.fromStrict bs in if countBits lbs > fromIntegral dsaQLen then B.take (dsaQLen `div` 8) bs else bs -- FIXME: uneven bits
              dsaQLen = numBits q