    -- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing
    -- Copyright © 2012-2019  Clint Adams
    -- This software is released under the terms of the Expat license.
    -- (See the LICENSE file).
    module Codec.Encryption.OpenPGP.KeyringParser
      (
     -- * Parsers
        parseAChunk
      , finalizeParsing
      , anyTK
      , UidOrUat(..)
      , splitUs
      , publicTK
      , secretTK
      , brokenTK
      , pkPayload
      , signature
      , signedUID
      , signedUAt
      , signedOrRevokedPubSubkey
      , brokenPubSubkey
      , rawOrSignedOrRevokedSecSubkey
      , brokenSecSubkey
      , skPayload
      , broken
     -- * Utilities
      , parseTKs
      ) where

    import Control.Applicative ((<|>), many)
    import Data.Maybe (catMaybes)
    import Data.Monoid ((<>))

    import Data.Text (Text)

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

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

    anyTK :: Bool -> Parser [Pkt] (Maybe TK)
    anyTK True = publicTK True <|> secretTK True
    anyTK 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
      pkpkts <- satisfy isPKP
      case pkpkts of
        [PublicKeyPkt p] -> return (p, Nothing)
        _ -> failure
      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
          spks <- satisfy (isSP intolerant)
          case spks of
            [SignaturePkt sp] ->
              return $!
              (if intolerant
                 then id
                 else filter isSP')
                [sp]
            _ -> failure
        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
      upkts <- satisfy isUID
      case upkts of
        [UserIdPkt u] -> do
          sigs <-
            concatMany
              (signature
                 intolerant
                 [ GenericCert
                 , PersonaCert
                 , CasualCert
                 , PositiveCert
                 , CertRevocationSig
                 ])
          return (I u, sigs)
        _ -> failure
      where
        isUID [UserIdPkt _] = True
        isUID _ = False

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

    signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
    signedOrRevokedPubSubkey intolerant = do
      pskpkts <- satisfy isPSKP
      case pskpkts of
        [p] -> do
          sigs <-
            concatMany
              (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])
          return [(p, sigs)]
        _ -> failure
      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
      sskpkts <- satisfy isSSKP
      case sskpkts of
        [p] -> do
          sigs <-
            concatMany
              (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])
          return [(p, sigs)]
        _ -> failure
      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
      spkts <- satisfy isSKP
      case spkts of
        [SecretKeyPkt p ska] -> return (p, Just ska)
        _ -> failure
      where
        isSKP [SecretKeyPkt _ _] = True
        isSKP _ = False

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

    -- | parse TKs from packets
    parseTKs :: Bool -> [Pkt] -> [TK]
    parseTKs intolerant ps =
      catMaybes
        (concatMap
           fst
           (completeResults
              (feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant))))))
      where
        notTrustPacket = not . isTrustPkt