-- Internal.hs: private utility functions
-- Copyright © 2012-2014  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
 , beBSToInteger
 , integerToBEBS
 , PktStreamContext(..)
 , hashDescr
 , issuer
 , emptyPSC
 , pubkeyToMPIs
 , multiplicativeInverse
 , sigType
 , sigPKA
 , sigHA
 , sigCT
) where

import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512, hashDescrRIPEMD160)
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.RSA as RSA

import Data.Bits (testBit, shiftL, shiftR, (.&.))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.List (find, mapAccumR, unfoldr)
import Data.Word (Word8, Word16)

import Codec.Encryption.OpenPGP.Types

countBits :: ByteString -> Word16
countBits bs
    | B.null bs = 0
    | otherwise = fromIntegral (B.length bs * 8) - fromIntegral (go (B.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)

beBSToInteger :: ByteString -> Integer
beBSToInteger = sum . snd . mapAccumR (\acc x -> (acc + 8, fromIntegral x `shiftL` acc)) 0 . B.unpack

integerToBEBS :: Integer -> ByteString
integerToBEBS = B.pack . reverse . unfoldr (\x -> if x == 0 then Nothing else Just ((fromIntegral x :: Word8) .&. 0xff, x `shiftR` 8))

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 isIssuer usubs)
    where
        isIssuer (SigSubPacket _ (Issuer _)) = True
        isIssuer _ = False
issuer _ = Nothing

hashDescr :: HashAlgorithm -> Either String HashDescr
hashDescr SHA1 = Right hashDescrSHA1
hashDescr RIPEMD160 = Right hashDescrRIPEMD160
hashDescr SHA256 = Right hashDescrSHA256
hashDescr SHA384 = Right hashDescrSHA384
hashDescr SHA512 = Right hashDescrSHA512
hashDescr SHA224 = Right hashDescrSHA224
hashDescr DeprecatedMD5 = Right hashDescrMD5
hashDescr x = Left $ "Unknown hash problem: " ++ show x

pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs (RSAPubKey k) = [MPI (RSA.public_n k), MPI (RSA.public_e k)]
pubkeyToMPIs (DSAPubKey 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 k) = fmap MPI k

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 TimeStamp
sigCT (SigV3 _ ct _ _ _ _ _) = Just ct
sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs)
    where
        isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True
        isSigCreationTime _ = False
sigCT _ = Nothing