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