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

{-# LANGUAGE CPP #-}

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.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) =
#if MIN_VERSION_incremental_parser(0,4,0)
  either error (\x -> (x, map fst cr)) (inspect (feed (mconcat (map snd cr) <> a) op))
parseAChunk _ a (_, Just (_, p)) = either error (\x -> (x, [])) (inspect (feed a p))
#else
  (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr)
parseAChunk _ a (_, Just (_, p)) = (inspect (feed a p), [])
#endif

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)
#if MIN_VERSION_incremental_parser(0,4,0)
finalizeParsing (_, Just (_, p)) = either error finalizeParsing (inspect (feedEof p))
#else
finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p))
#endif

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