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, (<$>), (<|>))
import Data.Monoid (Monoid, (<>), mconcat)
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 String | A [UserAttrSubPacket]
deriving Show
splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(String, [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))
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))
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