{-# LANGUAGE CPP #-}
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 :: 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 :: s
a ([], Nothing) = [Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a. HasCallStack => [Char] -> a
error ([Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> [Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a b. (a -> b) -> a -> b
$ "Failure before " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ s -> [Char]
forall a. Show a => a -> [Char]
show s
a
parseAChunk op :: Parser s r
op a :: s
a (cr :: [(r, s)]
cr, Nothing) =
#if MIN_VERSION_incremental_parser(0,4,0)
([Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a. HasCallStack => [Char] -> a
error (\x :: ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
x -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r))
x, ((r, s) -> r) -> [(r, s)] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map (r, s) -> r
forall a b. (a, b) -> a
fst [(r, s)]
cr)) (Parser s r
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
forall t s r.
Parser t s r
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser t s r))
inspect (s -> Parser s r -> Parser s r
forall s t r. Monoid s => s -> Parser t s r -> Parser t s r
feed ([s] -> s
forall a. Monoid a => [a] -> a
mconcat (((r, s) -> s) -> [(r, s)] -> [s]
forall a b. (a -> b) -> [a] -> [b]
map (r, s) -> s
forall a b. (a, b) -> b
snd [(r, s)]
cr) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
a) Parser s r
op))
parseAChunk _ a :: s
a (_, Just (_, p :: Parser s r
p)) = ([Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a. HasCallStack => [Char] -> a
error (\x :: ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
x -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r))
x, [])) (Parser s r
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
forall t s r.
Parser t s r
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser t s r))
inspect (s -> Parser s r -> Parser s r
forall s t r. Monoid s => s -> Parser t s r -> Parser t s r
feed s
a Parser s r
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 :: ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
finalizeParsing ([], Nothing) = [Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a. HasCallStack => [Char] -> a
error "Unexpected finalization failure"
finalizeParsing (cr :: [(r, s)]
cr, Nothing) = (([], Maybe (Maybe (r -> r), Parser s r)
forall a. Maybe a
Nothing), ((r, s) -> r) -> [(r, s)] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map (r, s) -> r
forall a b. (a, b) -> a
fst [(r, s)]
cr)
#if MIN_VERSION_incremental_parser(0,4,0)
finalizeParsing (_, Just (_, p :: Parser s r
p)) = ([Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]))
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall a. HasCallStack => [Char] -> a
error ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
forall s r.
Monoid s =>
([(r, s)], Maybe (Maybe (r -> r), Parser s r))
-> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
finalizeParsing (Parser s r
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
forall t s r.
Parser t s r
-> Either [Char] ([(r, s)], Maybe (Maybe (r -> r), Parser t s r))
inspect (Parser s r -> Parser s r
forall s t r. Monoid s => Parser t s r -> Parser t s r
feedEof Parser s r
p))
#else
finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p))
#endif
anyTK :: Bool -> Parser [Pkt] (Maybe TK)
anyTK :: Bool -> Parser [Pkt] (Maybe TK)
anyTK True = Bool -> Parser [Pkt] (Maybe TK)
publicTK Bool
True Parser [Pkt] (Maybe TK)
-> Parser [Pkt] (Maybe TK) -> Parser [Pkt] (Maybe TK)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser [Pkt] (Maybe TK)
secretTK Bool
True
anyTK False = Bool -> Parser [Pkt] (Maybe TK)
publicTK Bool
False Parser [Pkt] (Maybe TK)
-> Parser [Pkt] (Maybe TK) -> Parser [Pkt] (Maybe TK)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser [Pkt] (Maybe TK)
secretTK Bool
False Parser [Pkt] (Maybe TK)
-> Parser [Pkt] (Maybe TK) -> Parser [Pkt] (Maybe TK)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser [Pkt] (Maybe TK)
brokenTK 6 Parser [Pkt] (Maybe TK)
-> Parser [Pkt] (Maybe TK) -> Parser [Pkt] (Maybe TK)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser [Pkt] (Maybe TK)
brokenTK 5
data UidOrUat
= I Text
| A [UserAttrSubPacket]
deriving (Int -> UidOrUat -> [Char] -> [Char]
[UidOrUat] -> [Char] -> [Char]
UidOrUat -> [Char]
(Int -> UidOrUat -> [Char] -> [Char])
-> (UidOrUat -> [Char])
-> ([UidOrUat] -> [Char] -> [Char])
-> Show UidOrUat
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [UidOrUat] -> [Char] -> [Char]
$cshowList :: [UidOrUat] -> [Char] -> [Char]
show :: UidOrUat -> [Char]
$cshow :: UidOrUat -> [Char]
showsPrec :: Int -> UidOrUat -> [Char] -> [Char]
$cshowsPrec :: Int -> UidOrUat -> [Char] -> [Char]
Show)
splitUs ::
[(UidOrUat, [SignaturePayload])]
-> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])
splitUs :: [(UidOrUat, [SignaturePayload])]
-> ([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])])
splitUs us :: [(UidOrUat, [SignaturePayload])]
us = ([(Text, [SignaturePayload])]
is, [([UserAttrSubPacket], [SignaturePayload])]
as)
where
is :: [(Text, [SignaturePayload])]
is = ((UidOrUat, [SignaturePayload]) -> (Text, [SignaturePayload]))
-> [(UidOrUat, [SignaturePayload])] -> [(Text, [SignaturePayload])]
forall a b. (a -> b) -> [a] -> [b]
map (UidOrUat, [SignaturePayload]) -> (Text, [SignaturePayload])
forall b. Show b => (UidOrUat, b) -> (Text, b)
unI (((UidOrUat, [SignaturePayload]) -> Bool)
-> [(UidOrUat, [SignaturePayload])]
-> [(UidOrUat, [SignaturePayload])]
forall a. (a -> Bool) -> [a] -> [a]
filter (UidOrUat, [SignaturePayload]) -> Bool
forall b. (UidOrUat, b) -> Bool
isI [(UidOrUat, [SignaturePayload])]
us)
as :: [([UserAttrSubPacket], [SignaturePayload])]
as = ((UidOrUat, [SignaturePayload])
-> ([UserAttrSubPacket], [SignaturePayload]))
-> [(UidOrUat, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall a b. (a -> b) -> [a] -> [b]
map (UidOrUat, [SignaturePayload])
-> ([UserAttrSubPacket], [SignaturePayload])
forall b. Show b => (UidOrUat, b) -> ([UserAttrSubPacket], b)
unA (((UidOrUat, [SignaturePayload]) -> Bool)
-> [(UidOrUat, [SignaturePayload])]
-> [(UidOrUat, [SignaturePayload])]
forall a. (a -> Bool) -> [a] -> [a]
filter (UidOrUat, [SignaturePayload]) -> Bool
forall b. (UidOrUat, b) -> Bool
isA [(UidOrUat, [SignaturePayload])]
us)
isI :: (UidOrUat, b) -> Bool
isI (I _, _) = Bool
True
isI _ = Bool
False
isA :: (UidOrUat, b) -> Bool
isA (A _, _) = Bool
True
isA _ = Bool
False
unI :: (UidOrUat, b) -> (Text, b)
unI (I x :: Text
x, y :: b
y) = (Text
x, b
y)
unI x :: (UidOrUat, b)
x = [Char] -> (Text, b)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Text, b)) -> [Char] -> (Text, b)
forall a b. (a -> b) -> a -> b
$ "unI should never be called on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (UidOrUat, b) -> [Char]
forall a. Show a => a -> [Char]
show (UidOrUat, b)
x
unA :: (UidOrUat, b) -> ([UserAttrSubPacket], b)
unA (A x :: [UserAttrSubPacket]
x, y :: b
y) = ([UserAttrSubPacket]
x, b
y)
unA x :: (UidOrUat, b)
x = [Char] -> ([UserAttrSubPacket], b)
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([UserAttrSubPacket], b))
-> [Char] -> ([UserAttrSubPacket], b)
forall a b. (a -> b) -> a -> b
$ "unA should never be called on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (UidOrUat, b) -> [Char]
forall a. Show a => a -> [Char]
show (UidOrUat, b)
x
publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK)
publicTK :: Bool -> Parser [Pkt] (Maybe TK)
publicTK intolerant :: Bool
intolerant = do
(PKPayload, Maybe SKAddendum)
pkp <- Parser [Pkt] (PKPayload, Maybe SKAddendum)
pkPayload
[SignaturePayload]
pkpsigs <-
Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany
(Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
intolerant [SigType
KeyRevocationSig, SigType
SignatureDirectlyOnAKey])
(uids :: [(Text, [SignaturePayload])]
uids, uats :: [([UserAttrSubPacket], [SignaturePayload])]
uats) <-
([(UidOrUat, [SignaturePayload])]
-> ([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])]))
-> Parser LeftBiasedLocal [Pkt] [(UidOrUat, [SignaturePayload])]
-> Parser
LeftBiasedLocal
[Pkt]
([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(UidOrUat, [SignaturePayload])]
-> ([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])])
splitUs (Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] [(UidOrUat, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUID Bool
intolerant Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUAt Bool
intolerant))
[(Pkt, [SignaturePayload])]
subs <- Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany (Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
pubsub Bool
intolerant)
Maybe TK -> Parser [Pkt] (Maybe TK)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TK -> Parser [Pkt] (Maybe TK))
-> Maybe TK -> Parser [Pkt] (Maybe TK)
forall a b. (a -> b) -> a -> b
$ TK -> Maybe TK
forall a. a -> Maybe a
Just ((PKPayload, Maybe SKAddendum)
-> [SignaturePayload]
-> [(Text, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [(Pkt, [SignaturePayload])]
-> TK
TK (PKPayload, Maybe SKAddendum)
pkp [SignaturePayload]
pkpsigs [(Text, [SignaturePayload])]
uids [([UserAttrSubPacket], [SignaturePayload])]
uats [(Pkt, [SignaturePayload])]
subs)
where
pubsub :: Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
pubsub True = Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey Bool
True
pubsub False = Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey Bool
False Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
brokenPubSubkey
secretTK :: Bool -> Parser [Pkt] (Maybe TK)
secretTK intolerant :: Bool
intolerant = do
(PKPayload, Maybe SKAddendum)
skp <- Parser [Pkt] (PKPayload, Maybe SKAddendum)
skPayload
[SignaturePayload]
skpsigs <-
Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany
(Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
intolerant [SigType
KeyRevocationSig, SigType
SignatureDirectlyOnAKey])
(uids :: [(Text, [SignaturePayload])]
uids, uats :: [([UserAttrSubPacket], [SignaturePayload])]
uats) <-
([(UidOrUat, [SignaturePayload])]
-> ([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])]))
-> Parser LeftBiasedLocal [Pkt] [(UidOrUat, [SignaturePayload])]
-> Parser
LeftBiasedLocal
[Pkt]
([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(UidOrUat, [SignaturePayload])]
-> ([(Text, [SignaturePayload])],
[([UserAttrSubPacket], [SignaturePayload])])
splitUs (Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] [(UidOrUat, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUID Bool
intolerant Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUAt Bool
intolerant))
[(Pkt, [SignaturePayload])]
subs <- Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany (Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
secsub Bool
intolerant)
Maybe TK -> Parser [Pkt] (Maybe TK)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TK -> Parser [Pkt] (Maybe TK))
-> Maybe TK -> Parser [Pkt] (Maybe TK)
forall a b. (a -> b) -> a -> b
$ TK -> Maybe TK
forall a. a -> Maybe a
Just ((PKPayload, Maybe SKAddendum)
-> [SignaturePayload]
-> [(Text, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [(Pkt, [SignaturePayload])]
-> TK
TK (PKPayload, Maybe SKAddendum)
skp [SignaturePayload]
skpsigs [(Text, [SignaturePayload])]
uids [([UserAttrSubPacket], [SignaturePayload])]
uats [(Pkt, [SignaturePayload])]
subs)
where
secsub :: Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
secsub True = Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey Bool
True
secsub False = Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey Bool
False Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
brokenSecSubkey
brokenTK :: Int -> Parser [Pkt] (Maybe TK)
brokenTK :: Int -> Parser [Pkt] (Maybe TK)
brokenTK 6 = do
Pkt
_ <- Int -> Parser [Pkt] Pkt
broken 6
[[SignaturePayload]]
_ <- Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [[SignaturePayload]]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
False [SigType
KeyRevocationSig, SigType
SignatureDirectlyOnAKey])
[(UidOrUat, [SignaturePayload])]
_ <- Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] [(UidOrUat, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUID Bool
False Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUAt Bool
False)
[(Pkt, [SignaturePayload])]
_ <- Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany (Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey Bool
False Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
brokenPubSubkey)
Maybe TK -> Parser [Pkt] (Maybe TK)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TK
forall a. Maybe a
Nothing
brokenTK 5 = do
Pkt
_ <- Int -> Parser [Pkt] Pkt
broken 5
[[SignaturePayload]]
_ <- Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [[SignaturePayload]]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
False [SigType
KeyRevocationSig, SigType
SignatureDirectlyOnAKey])
[(UidOrUat, [SignaturePayload])]
_ <- Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] [(UidOrUat, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUID Bool
False Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUAt Bool
False)
[(Pkt, [SignaturePayload])]
_ <- Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany (Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey Bool
False Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
brokenSecSubkey)
Maybe TK -> Parser [Pkt] (Maybe TK)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TK
forall a. Maybe a
Nothing
brokenTK _ = [Char] -> Parser [Pkt] (Maybe TK)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "Unexpected broken packet type"
pkPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)
pkPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)
pkPayload = do
[Pkt]
pkpkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isPKP
case [Pkt]
pkpkts of
[PublicKeyPkt p :: PKPayload
p] -> (PKPayload, Maybe SKAddendum)
-> Parser [Pkt] (PKPayload, Maybe SKAddendum)
forall (m :: * -> *) a. Monad m => a -> m a
return (PKPayload
p, Maybe SKAddendum
forall a. Maybe a
Nothing)
_ -> Parser [Pkt] (PKPayload, Maybe SKAddendum)
forall t s r. Parser t s r
failure
where
isPKP :: [Pkt] -> Bool
isPKP [PublicKeyPkt _] = Bool
True
isPKP _ = Bool
False
signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]
signature :: Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature intolerant :: Bool
intolerant rts :: [SigType]
rts =
if Bool
intolerant
then Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall t. Parser t [Pkt] [SignaturePayload]
signature'
else Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall t. Parser t [Pkt] [SignaturePayload]
signature' Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall a. Parser LeftBiasedLocal [Pkt] [a]
brokensig'
where
signature' :: Parser t [Pkt] [SignaturePayload]
signature' = do
[Pkt]
spks <- ([Pkt] -> Bool) -> Parser t [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy (Bool -> [Pkt] -> Bool
isSP Bool
intolerant)
case [Pkt]
spks of
[SignaturePkt sp :: SignaturePayload
sp] ->
[SignaturePayload] -> Parser t [Pkt] [SignaturePayload]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SignaturePayload] -> Parser t [Pkt] [SignaturePayload])
-> [SignaturePayload] -> Parser t [Pkt] [SignaturePayload]
forall a b. (a -> b) -> a -> b
$!
(if Bool
intolerant
then [SignaturePayload] -> [SignaturePayload]
forall a. a -> a
id
else (SignaturePayload -> Bool)
-> [SignaturePayload] -> [SignaturePayload]
forall a. (a -> Bool) -> [a] -> [a]
filter SignaturePayload -> Bool
isSP')
[SignaturePayload
sp]
_ -> Parser t [Pkt] [SignaturePayload]
forall t s r. Parser t s r
failure
brokensig' :: Parser LeftBiasedLocal [Pkt] [a]
brokensig' = [a] -> Pkt -> [a]
forall a b. a -> b -> a
const [] (Pkt -> [a])
-> Parser [Pkt] Pkt -> Parser LeftBiasedLocal [Pkt] [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser [Pkt] Pkt
broken 2
isSP :: Bool -> [Pkt] -> Bool
isSP True [SignaturePkt sp :: SignaturePayload
sp@SigV3 {}] = SignaturePayload -> Bool
isSP' SignaturePayload
sp
isSP True [SignaturePkt sp :: SignaturePayload
sp@SigV4 {}] = SignaturePayload -> Bool
isSP' SignaturePayload
sp
isSP False [SignaturePkt _] = Bool
True
isSP _ _ = Bool
False
isSP' :: SignaturePayload -> Bool
isSP' (SigV3 st :: SigType
st _ _ _ _ _ _) = SigType
st SigType -> [SigType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SigType]
rts
isSP' (SigV4 st :: SigType
st _ _ _ _ _ _) = SigType
st SigType -> [SigType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SigType]
rts
isSP' _ = Bool
False
signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])
signedUID :: Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUID intolerant :: Bool
intolerant = do
[Pkt]
upkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isUID
case [Pkt]
upkts of
[UserIdPkt u :: Text
u] -> do
[SignaturePayload]
sigs <-
Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany
(Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature
Bool
intolerant
[ SigType
GenericCert
, SigType
PersonaCert
, SigType
CasualCert
, SigType
PositiveCert
, SigType
CertRevocationSig
])
(UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> UidOrUat
I Text
u, [SignaturePayload]
sigs)
_ -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall t s r. Parser t s r
failure
where
isUID :: [Pkt] -> Bool
isUID [UserIdPkt _] = Bool
True
isUID _ = Bool
False
signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])
signedUAt :: Bool -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
signedUAt intolerant :: Bool
intolerant = do
[Pkt]
uapkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isUAt
case [Pkt]
uapkts of
[UserAttributePkt us :: [UserAttrSubPacket]
us] -> do
[SignaturePayload]
sigs <-
Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany
(Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature
Bool
intolerant
[ SigType
GenericCert
, SigType
PersonaCert
, SigType
CasualCert
, SigType
PositiveCert
, SigType
CertRevocationSig
])
(UidOrUat, [SignaturePayload])
-> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall (m :: * -> *) a. Monad m => a -> m a
return ([UserAttrSubPacket] -> UidOrUat
A [UserAttrSubPacket]
us, [SignaturePayload]
sigs)
_ -> Parser LeftBiasedLocal [Pkt] (UidOrUat, [SignaturePayload])
forall t s r. Parser t s r
failure
where
isUAt :: [Pkt] -> Bool
isUAt [UserAttributePkt _] = Bool
True
isUAt _ = Bool
False
signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey :: Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey intolerant :: Bool
intolerant = do
[Pkt]
pskpkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isPSKP
case [Pkt]
pskpkts of
[p :: Pkt
p] -> do
[SignaturePayload]
sigs <-
Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany
(Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
intolerant [SigType
SubkeyBindingSig, SigType
SubkeyRevocationSig])
[(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pkt
p, [SignaturePayload]
sigs)]
_ -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall t s r. Parser t s r
failure
where
isPSKP :: [Pkt] -> Bool
isPSKP [PublicSubkeyPkt _] = Bool
True
isPSKP _ = Bool
False
brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]
brokenPubSubkey :: Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
brokenPubSubkey = do
Pkt
_ <- Int -> Parser [Pkt] Pkt
broken 14
[SignaturePayload]
_ <- Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany (Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
False [SigType
SubkeyBindingSig, SigType
SubkeyRevocationSig])
[(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
rawOrSignedOrRevokedSecSubkey ::
Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey :: Bool -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey intolerant :: Bool
intolerant = do
[Pkt]
sskpkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isSSKP
case [Pkt]
sskpkts of
[p :: Pkt
p] -> do
[SignaturePayload]
sigs <-
Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany
(Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
intolerant [SigType
SubkeyBindingSig, SigType
SubkeyRevocationSig])
[(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pkt
p, [SignaturePayload]
sigs)]
_ -> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall t s r. Parser t s r
failure
where
isSSKP :: [Pkt] -> Bool
isSSKP [SecretSubkeyPkt _ _] = Bool
True
isSSKP _ = Bool
False
brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]
brokenSecSubkey :: Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
brokenSecSubkey = do
Pkt
_ <- Int -> Parser [Pkt] Pkt
broken 7
[SignaturePayload]
_ <- Parser LeftBiasedLocal [Pkt] [SignaturePayload]
-> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
forall (f :: * -> *) a.
(MonoidAlternative f, Semigroup a, Monoid a) =>
f a -> f a
concatMany (Bool
-> [SigType] -> Parser LeftBiasedLocal [Pkt] [SignaturePayload]
signature Bool
False [SigType
SubkeyBindingSig, SigType
SubkeyRevocationSig])
[(Pkt, [SignaturePayload])]
-> Parser LeftBiasedLocal [Pkt] [(Pkt, [SignaturePayload])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)
skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)
skPayload = do
[Pkt]
spkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isSKP
case [Pkt]
spkts of
[SecretKeyPkt p :: PKPayload
p ska :: SKAddendum
ska] -> (PKPayload, Maybe SKAddendum)
-> Parser [Pkt] (PKPayload, Maybe SKAddendum)
forall (m :: * -> *) a. Monad m => a -> m a
return (PKPayload
p, SKAddendum -> Maybe SKAddendum
forall a. a -> Maybe a
Just SKAddendum
ska)
_ -> Parser [Pkt] (PKPayload, Maybe SKAddendum)
forall t s r. Parser t s r
failure
where
isSKP :: [Pkt] -> Bool
isSKP [SecretKeyPkt _ _] = Bool
True
isSKP _ = Bool
False
broken :: Int -> Parser [Pkt] Pkt
broken :: Int -> Parser [Pkt] Pkt
broken t :: Int
t = do
[Pkt]
bpkts <- ([Pkt] -> Bool) -> Parser LeftBiasedLocal [Pkt] [Pkt]
forall s t. FactorialMonoid s => (s -> Bool) -> Parser t s s
satisfy [Pkt] -> Bool
isBroken
case [Pkt]
bpkts of
[bp :: Pkt
bp] -> Pkt -> Parser [Pkt] Pkt
forall (m :: * -> *) a. Monad m => a -> m a
return Pkt
bp
_ -> Parser [Pkt] Pkt
forall t s r. Parser t s r
failure
where
isBroken :: [Pkt] -> Bool
isBroken [BrokenPacketPkt _ a :: Word8
a _] = Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a
isBroken _ = Bool
False
parseTKs :: Bool -> [Pkt] -> [TK]
parseTKs :: Bool -> [Pkt] -> [TK]
parseTKs intolerant :: Bool
intolerant ps :: [Pkt]
ps =
[Maybe TK] -> [TK]
forall a. [Maybe a] -> [a]
catMaybes
((([Maybe TK], [Pkt]) -> [Maybe TK])
-> [([Maybe TK], [Pkt])] -> [Maybe TK]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
([Maybe TK], [Pkt]) -> [Maybe TK]
forall a b. (a, b) -> a
fst
(Parser LeftBiasedLocal [Pkt] [Maybe TK] -> [([Maybe TK], [Pkt])]
forall s t r. Monoid s => Parser t s r -> [(r, s)]
completeResults
(Parser LeftBiasedLocal [Pkt] [Maybe TK]
-> Parser LeftBiasedLocal [Pkt] [Maybe TK]
forall s t r. Monoid s => Parser t s r -> Parser t s r
feedEof ([Pkt]
-> Parser LeftBiasedLocal [Pkt] [Maybe TK]
-> Parser LeftBiasedLocal [Pkt] [Maybe TK]
forall s t r. Monoid s => s -> Parser t s r -> Parser t s r
feed ((Pkt -> Bool) -> [Pkt] -> [Pkt]
forall a. (a -> Bool) -> [a] -> [a]
filter Pkt -> Bool
notTrustPacket [Pkt]
ps) (Parser [Pkt] (Maybe TK) -> Parser LeftBiasedLocal [Pkt] [Maybe TK]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser [Pkt] (Maybe TK)
anyTK Bool
intolerant))))))
where
notTrustPacket :: Pkt -> Bool
notTrustPacket = Bool -> Bool
not (Bool -> Bool) -> (Pkt -> Bool) -> Pkt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkt -> Bool
isTrustPkt