-- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing
-- Copyright © 2012-2016  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE CPP #-}

module Codec.Encryption.OpenPGP.KeyringParser (
   parseAChunk
 , finalizeParsing
 , parseTK
 , UidOrUat(..)
 , splitUs
 , publicTK
 , secretTK
 , brokenTK
 , pkPayload
 , signature
 , signedUID
 , signedUAt
 , signedOrRevokedPubSubkey
 , brokenPubSubkey
 , rawOrSignedOrRevokedSecSubkey
 , brokenSecSubkey
 , skPayload
 , broken
) where

import Control.Applicative (many, (<|>))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mconcat)
#endif
import Data.Monoid ((<>))

import Data.Text (Text)

import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Keyring.Instances ()
import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, feed, feedEof, inspect, satisfy, Parser)

parseAChunk :: (Monoid s, Show s) => Parser s r -> s -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
parseAChunk _ a ([], Nothing) = error $ "Failure before " ++ show a
parseAChunk op a (cr, Nothing) = (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr)
parseAChunk _ a (_, Just (_, p)) = (inspect (feed a p), [])

finalizeParsing :: Monoid s => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
finalizeParsing ([], Nothing) = error "Unexpected finalization failure"
finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr)
finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p))

parseTK :: Bool -> Parser [Pkt] (Maybe TK)
parseTK True = publicTK True <|> secretTK True
parseTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5

data UidOrUat = I Text | A [UserAttrSubPacket]
    deriving Show

splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])
splitUs us = (is, as)
    where
        is = map unI (filter isI us)
        as = map unA (filter isA us)
        isI (I _, _) = True
        isI _ = False
        isA (A _, _) = True
        isA _ = False
        unI (I x, y) = (x, y)
        unI x = error $ "unI should never be called on " ++ show x
        unA (A x, y) = (x, y)
        unA x = error $ "unA should never be called on " ++ show x

publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK)
publicTK intolerant = do
    pkp <- pkPayload
    pkpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])
    (uids, uats) <- fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant
    subs <- concatMany (pubsub intolerant)
    return $ Just (TK pkp pkpsigs uids uats subs)
        where
            pubsub True = signedOrRevokedPubSubkey True
            pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey
secretTK intolerant = do
    skp <- skPayload
    skpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])
    (uids, uats) <- fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant?
    subs <- concatMany (secsub intolerant)
    return $ Just (TK skp skpsigs uids uats subs)
        where
            secsub True = rawOrSignedOrRevokedSecSubkey True
            secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey

brokenTK :: Int -> Parser [Pkt] (Maybe TK)
brokenTK 6 = do
    _ <- broken 6
    _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])
    _ <- many (signedUID False <|> signedUAt False)
    _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey)
    return Nothing
brokenTK 5 = do
    _ <- broken 5
    _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])
    _ <- many (signedUID False <|> signedUAt False)
    _ <- concatMany (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey)
    return Nothing
brokenTK _ = fail "Unexpected broken packet type"

pkPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)
pkPayload = do [PublicKeyPkt p] <- satisfy isPKP
               return (p, Nothing)
    where
        isPKP [PublicKeyPkt _] = True
        isPKP _ = False

signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]
signature intolerant rts = if intolerant then signature' else signature' <|> brokensig'
    where
        signature' = do [SignaturePkt sp] <- satisfy (isSP intolerant)
                        return $! (if intolerant then id else filter isSP') [sp]
        brokensig' = const [] <$> broken 2
        isSP True [SignaturePkt sp@(SigV3 {})] = isSP' sp
        isSP True [SignaturePkt sp@(SigV4 {})] = isSP' sp
        isSP False [SignaturePkt _] = True
        isSP _ _ = False
        isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts
        isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts
        isSP' _ = False

signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])
signedUID intolerant = do [UserIdPkt u] <- satisfy isUID
                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])
                          return (I u, sigs)
    where
        isUID [UserIdPkt _] = True
        isUID _ = False

signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])
signedUAt intolerant = do [UserAttributePkt us] <- satisfy isUAt
                          sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])
                          return (A us, sigs)
    where
        isUAt [UserAttributePkt _] = True
        isUAt _ = False

signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey intolerant = do [p] <- satisfy isPSKP
                                         sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])
                                         return [(p, sigs)]
    where
        isPSKP [PublicSubkeyPkt _] = True
        isPSKP _ = False

brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]
brokenPubSubkey = do _ <- broken 14
                     _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])
                     return []

rawOrSignedOrRevokedSecSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey intolerant = do [p] <- satisfy isSSKP
                                              sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])
                                              return [(p, sigs)]
    where
        isSSKP [SecretSubkeyPkt _ _] = True
        isSSKP _ = False

brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]
brokenSecSubkey = do _ <- broken 7
                     _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])
                     return []

skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)
skPayload = do [SecretKeyPkt p ska] <- satisfy isSKP
               return (p, Just ska)
    where
        isSKP [SecretKeyPkt _ _] = True
        isSKP _ = False

broken :: Int -> Parser [Pkt] Pkt
broken t = do [bp] <- satisfy isBroken
              return bp
    where
        isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a
        isBroken _ = False