module Codec.Encryption.OpenPGP.KeyringParser
(
parseAChunk
, finalizeParsing
, anyTK
, UidOrUat(..)
, splitUs
, publicTK
, secretTK
, brokenTK
, pkPayload
, signature
, signedUID
, signedUAt
, signedOrRevokedPubSubkey
, brokenPubSubkey
, rawOrSignedOrRevokedSecSubkey
, brokenSecSubkey
, skPayload
, broken
, 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))
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
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
parseTKs :: Bool -> [Pkt] -> [TK]
parseTKs intolerant ps =
catMaybes
(concatMap
fst
(completeResults
(feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant))))))
where
notTrustPacket = not . isTrustPkt