-- Instances.hs: OpenPGP (RFC9580) additional types for transferable keys
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Data.Conduit.OpenPGP.Keyring.Instances
  (
  ) where

import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Internal (issuer)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
import Codec.Encryption.OpenPGP.Types
import Control.Arrow (second)
import Control.Lens ((^.), (^..), _1, folded)
import Data.Data.Lens (biplate)
import Data.Either (rights)
import Data.Function (on)
import qualified Data.HashMap.Lazy as HashMap
import Data.IxSet.Typed (Indexable(..), ixFun, ixList)
import Data.List (nub, sort)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Semigroup (Semigroup, (<>))
import Data.Text (Text)

instance Indexable KeyringIxs TKUnknown where
  indices :: IxList KeyringIxs TKUnknown
indices = Ix EightOctetKeyId TKUnknown
-> Ix Fingerprint TKUnknown
-> Ix Text TKUnknown
-> IxList KeyringIxs TKUnknown
forall (ixs :: [*]) a r. MkIxList ixs ixs a r => r
ixList ((TKUnknown -> [EightOctetKeyId]) -> Ix EightOctetKeyId TKUnknown
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TKUnknown -> [EightOctetKeyId]
getEOKIs) ((TKUnknown -> [Fingerprint]) -> Ix Fingerprint TKUnknown
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TKUnknown -> [Fingerprint]
getFingerprints) ((TKUnknown -> [Text]) -> Ix Text TKUnknown
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TKUnknown -> [Text]
getUIDs)

getEOKIs :: TKUnknown -> [EightOctetKeyId]
getEOKIs :: TKUnknown -> [EightOctetKeyId]
getEOKIs TKUnknown
tk = [Either String EightOctetKeyId] -> [EightOctetKeyId]
forall a b. [Either a b] -> [b]
rights ((SomePKPayload -> Either String EightOctetKeyId)
-> [SomePKPayload] -> [Either String EightOctetKeyId]
forall a b. (a -> b) -> [a] -> [b]
map SomePKPayload -> Either String EightOctetKeyId
eightOctetKeyID (TKUnknown
tk TKUnknown
-> Getting (Endo [SomePKPayload]) TKUnknown SomePKPayload
-> [SomePKPayload]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [SomePKPayload]) TKUnknown SomePKPayload
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' TKUnknown SomePKPayload
biplate :: [SomePKPayload]))

getFingerprints :: TKUnknown -> [Fingerprint]
getFingerprints :: TKUnknown -> [Fingerprint]
getFingerprints TKUnknown
tk = (SomePKPayload -> Fingerprint) -> [SomePKPayload] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map SomePKPayload -> Fingerprint
fingerprint (TKUnknown
tk TKUnknown
-> Getting (Endo [SomePKPayload]) TKUnknown SomePKPayload
-> [SomePKPayload]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [SomePKPayload]) TKUnknown SomePKPayload
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' TKUnknown SomePKPayload
biplate :: [SomePKPayload])

getUIDs :: TKUnknown -> [Text]
getUIDs :: TKUnknown -> [Text]
getUIDs TKUnknown
tk = (TKUnknown
tk TKUnknown
-> Getting
     [(Text, [SignaturePayload])] TKUnknown [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] TKUnknown [(Text, [SignaturePayload])]
Lens' TKUnknown [(Text, [SignaturePayload])]
tkuUIDs) [(Text, [SignaturePayload])]
-> Getting (Endo [Text]) [(Text, [SignaturePayload])] Text
-> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Text, [SignaturePayload])
 -> Const (Endo [Text]) (Text, [SignaturePayload]))
-> [(Text, [SignaturePayload])]
-> Const (Endo [Text]) [(Text, [SignaturePayload])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int [(Text, [SignaturePayload])] (Text, [SignaturePayload])
folded (((Text, [SignaturePayload])
  -> Const (Endo [Text]) (Text, [SignaturePayload]))
 -> [(Text, [SignaturePayload])]
 -> Const (Endo [Text]) [(Text, [SignaturePayload])])
-> ((Text -> Const (Endo [Text]) Text)
    -> (Text, [SignaturePayload])
    -> Const (Endo [Text]) (Text, [SignaturePayload]))
-> Getting (Endo [Text]) [(Text, [SignaturePayload])] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> (Text, [SignaturePayload])
-> Const (Endo [Text]) (Text, [SignaturePayload])
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Text, [SignaturePayload]) (Text, [SignaturePayload]) Text Text
_1

instance Semigroup TKUnknown where
  <> :: TKUnknown -> TKUnknown -> TKUnknown
(<>) TKUnknown
a TKUnknown
b =
    (SomePKPayload, Maybe SKAddendum)
-> [SignaturePayload]
-> [(Text, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [(Pkt, [SignaturePayload])]
-> TKUnknown
TKUnknown
      (TKUnknown -> (SomePKPayload, Maybe SKAddendum)
_tkuKey TKUnknown
a)
      ([SignaturePayload] -> [SignaturePayload]
forall a. Eq a => [a] -> [a]
nub ([SignaturePayload] -> [SignaturePayload])
-> ([SignaturePayload] -> [SignaturePayload])
-> [SignaturePayload]
-> [SignaturePayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SignaturePayload] -> [SignaturePayload]
forall a. Ord a => [a] -> [a]
sort ([SignaturePayload] -> [SignaturePayload])
-> [SignaturePayload] -> [SignaturePayload]
forall a b. (a -> b) -> a -> b
$ TKUnknown -> [SignaturePayload]
_tkuRevs TKUnknown
a [SignaturePayload] -> [SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a] -> [a]
++ TKUnknown -> [SignaturePayload]
_tkuRevs TKUnknown
b)
      (([(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]
forall {k} {a}.
(Ord k, Ord a) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge ([(Text, [SignaturePayload])]
 -> [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])])
-> (TKUnknown -> [(Text, [SignaturePayload])])
-> TKUnknown
-> TKUnknown
-> [(Text, [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TKUnknown -> [(Text, [SignaturePayload])]
_tkuUIDs) TKUnknown
a TKUnknown
b)
      (([([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall {k} {a}.
(Ord k, Ord a) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge ([([UserAttrSubPacket], [SignaturePayload])]
 -> [([UserAttrSubPacket], [SignaturePayload])]
 -> [([UserAttrSubPacket], [SignaturePayload])])
-> (TKUnknown -> [([UserAttrSubPacket], [SignaturePayload])])
-> TKUnknown
-> TKUnknown
-> [([UserAttrSubPacket], [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TKUnknown -> [([UserAttrSubPacket], [SignaturePayload])]
_tkuUAts) TKUnknown
a TKUnknown
b)
      (([(Pkt, [SignaturePayload])]
-> [(Pkt, [SignaturePayload])] -> [(Pkt, [SignaturePayload])]
forall {a} {k}.
(Ord a, Hashable k) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
ukvmerge ([(Pkt, [SignaturePayload])]
 -> [(Pkt, [SignaturePayload])] -> [(Pkt, [SignaturePayload])])
-> (TKUnknown -> [(Pkt, [SignaturePayload])])
-> TKUnknown
-> TKUnknown
-> [(Pkt, [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TKUnknown -> [(Pkt, [SignaturePayload])]
_tkuSubs) TKUnknown
a TKUnknown
b)
    where
      kvmerge :: [(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge [(k, [a])]
x [(k, [a])]
y =
        Map k [a] -> [(k, [a])]
forall k a. Map k a -> [(k, a)]
Map.toList (([a] -> [a] -> [a]) -> Map k [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [a] -> [a] -> [a]
forall {a}. Ord a => [a] -> [a] -> [a]
nsa ([(k, [a])] -> Map k [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, [a])]
x) ([(k, [a])] -> Map k [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, [a])]
y))
      ukvmerge :: [(k, [a])] -> [(k, [a])] -> [(k, [a])]
ukvmerge [(k, [a])]
x [(k, [a])]
y =
        HashMap k [a] -> [(k, [a])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList
          (([a] -> [a] -> [a])
-> HashMap k [a] -> HashMap k [a] -> HashMap k [a]
forall k v.
Eq k =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith [a] -> [a] -> [a]
forall {a}. Ord a => [a] -> [a] -> [a]
nsa ([(k, [a])] -> HashMap k [a]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(k, [a])]
x) ([(k, [a])] -> HashMap k [a]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(k, [a])]
y))
      nsa :: [a] -> [a] -> [a]
nsa [a]
x [a]
y = [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
y

instance Semigroup TKWithWireRep where
  <> :: TKWithWireRep -> TKWithWireRep -> TKWithWireRep
(<>) TKWithWireRep
a TKWithWireRep
b =
    let mergedTK :: TKUnknown
mergedTK = TKWithWireRep -> TKUnknown
_tkValue TKWithWireRep
a TKUnknown -> TKUnknown -> TKUnknown
forall a. Semigroup a => a -> a -> a
<> TKWithWireRep -> TKUnknown
_tkValue TKWithWireRep
b
        mergedPackets :: [PktWithWireRep]
mergedPackets =
          [Pkt] -> [PktWithWireRep] -> [PktWithWireRep]
selectPacketRefsByValue
            (TKUnknown -> [Pkt]
flattenTKPackets TKUnknown
mergedTK)
            ([PktWithWireRep] -> [PktWithWireRep]
dedupePacketRefsById (TKWithWireRep -> [PktWithWireRep]
_tkPackets TKWithWireRep
a [PktWithWireRep] -> [PktWithWireRep] -> [PktWithWireRep]
forall a. [a] -> [a] -> [a]
++ TKWithWireRep -> [PktWithWireRep]
_tkPackets TKWithWireRep
b))
     in WireRepRefs
-> Maybe ByteRange
-> [PktWithWireRep]
-> TKUnknown
-> TKWithWireRep
TKWithWireRep
          (WireRepRefs -> WireRepRefs -> WireRepRefs
mergeWireRepRefs (TKWithWireRep -> WireRepRefs
_tkWireRepRefs TKWithWireRep
a) (TKWithWireRep -> WireRepRefs
_tkWireRepRefs TKWithWireRep
b))
          ([PktWithWireRep] -> Maybe ByteRange
mergedWireRepRange [PktWithWireRep]
mergedPackets)
          [PktWithWireRep]
mergedPackets
          TKUnknown
mergedTK

flattenTKPackets :: TKUnknown -> [Pkt]
flattenTKPackets :: TKUnknown -> [Pkt]
flattenTKPackets TKUnknown
tk =
  [SomeKeyPkt -> Pkt
someKeyPktToPkt (SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt
mkPrimaryKeyPkt SomePKPayload
pkp Maybe SKAddendum
mska)] [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
  (SignaturePayload -> Pkt) -> [SignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map SignaturePayload -> Pkt
SignaturePkt (TKUnknown -> [SignaturePayload]
_tkuRevs TKUnknown
tk) [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
  ((Text, [SignaturePayload]) -> [Pkt])
-> [(Text, [SignaturePayload])] -> [Pkt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, [SignaturePayload]) -> [Pkt]
flattenUID (TKUnknown -> [(Text, [SignaturePayload])]
_tkuUIDs TKUnknown
tk) [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
  (([UserAttrSubPacket], [SignaturePayload]) -> [Pkt])
-> [([UserAttrSubPacket], [SignaturePayload])] -> [Pkt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([UserAttrSubPacket], [SignaturePayload]) -> [Pkt]
flattenUAT (TKUnknown -> [([UserAttrSubPacket], [SignaturePayload])]
_tkuUAts TKUnknown
tk) [Pkt] -> [Pkt] -> [Pkt]
forall a. [a] -> [a] -> [a]
++
  ((Pkt, [SignaturePayload]) -> [Pkt])
-> [(Pkt, [SignaturePayload])] -> [Pkt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Pkt, [SignaturePayload]) -> [Pkt]
flattenSub (TKUnknown -> [(Pkt, [SignaturePayload])]
_tkuSubs TKUnknown
tk)
  where
    (SomePKPayload
pkp, Maybe SKAddendum
mska) = TKUnknown -> (SomePKPayload, Maybe SKAddendum)
_tkuKey TKUnknown
tk
    flattenUID :: (Text, [SignaturePayload]) -> [Pkt]
flattenUID (Text
uid, [SignaturePayload]
sigs) = Text -> Pkt
UserIdPkt Text
uid Pkt -> [Pkt] -> [Pkt]
forall a. a -> [a] -> [a]
: (SignaturePayload -> Pkt) -> [SignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map SignaturePayload -> Pkt
SignaturePkt [SignaturePayload]
sigs
    flattenUAT :: ([UserAttrSubPacket], [SignaturePayload]) -> [Pkt]
flattenUAT ([UserAttrSubPacket]
uat, [SignaturePayload]
sigs) = [UserAttrSubPacket] -> Pkt
UserAttributePkt [UserAttrSubPacket]
uat Pkt -> [Pkt] -> [Pkt]
forall a. a -> [a] -> [a]
: (SignaturePayload -> Pkt) -> [SignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map SignaturePayload -> Pkt
SignaturePkt [SignaturePayload]
sigs
    flattenSub :: (Pkt, [SignaturePayload]) -> [Pkt]
flattenSub (Pkt
pkt, [SignaturePayload]
sigs) = Pkt
pkt Pkt -> [Pkt] -> [Pkt]
forall a. a -> [a] -> [a]
: (SignaturePayload -> Pkt) -> [SignaturePayload] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map SignaturePayload -> Pkt
SignaturePkt [SignaturePayload]
sigs

mergeWireRepRefs :: WireRepRefs -> WireRepRefs -> WireRepRefs
mergeWireRepRefs :: WireRepRefs -> WireRepRefs -> WireRepRefs
mergeWireRepRefs WireRepRefs
left WireRepRefs
right =
  case [WireRepRef] -> [WireRepRef]
forall a. Eq a => [a] -> [a]
dedupe (WireRepRefs -> [WireRepRef]
forall a. NonEmpty a -> [a]
NE.toList WireRepRefs
left [WireRepRef] -> [WireRepRef] -> [WireRepRef]
forall a. [a] -> [a] -> [a]
++ WireRepRefs -> [WireRepRef]
forall a. NonEmpty a -> [a]
NE.toList WireRepRefs
right) of
    [] -> WireRepRefs
left
    (WireRepRef
x:[WireRepRef]
xs) -> WireRepRef
x WireRepRef -> [WireRepRef] -> WireRepRefs
forall a. a -> [a] -> NonEmpty a
NE.:| [WireRepRef]
xs
  where
    dedupe :: [a] -> [a]
dedupe [] = []
    dedupe (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
dedupe ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x) [a]
xs)

mergedWireRepRange :: [PktWithWireRep] -> Maybe ByteRange
mergedWireRepRange :: [PktWithWireRep] -> Maybe ByteRange
mergedWireRepRange [] = Maybe ByteRange
forall a. Maybe a
Nothing
mergedWireRepRange (PktWithWireRep
pkt:[PktWithWireRep]
rest)
  | (PktWithWireRep -> Bool) -> [PktWithWireRep] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((WireRepRef -> WireRepRef -> Bool
forall a. Eq a => a -> a -> Bool
== PktWithWireRep -> WireRepRef
_pktWireRepRef PktWithWireRep
pkt) (WireRepRef -> Bool)
-> (PktWithWireRep -> WireRepRef) -> PktWithWireRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PktWithWireRep -> WireRepRef
_pktWireRepRef) [PktWithWireRep]
rest =
      [ByteRange] -> Maybe ByteRange
spanByteRanges ((PktWithWireRep -> ByteRange) -> [PktWithWireRep] -> [ByteRange]
forall a b. (a -> b) -> [a] -> [b]
map PktWithWireRep -> ByteRange
_pktRange (PktWithWireRep
pkt PktWithWireRep -> [PktWithWireRep] -> [PktWithWireRep]
forall a. a -> [a] -> [a]
: [PktWithWireRep]
rest))
  | Bool
otherwise = Maybe ByteRange
forall a. Maybe a
Nothing

dedupePacketRefsById :: [PktWithWireRep] -> [PktWithWireRep]
dedupePacketRefsById :: [PktWithWireRep] -> [PktWithWireRep]
dedupePacketRefsById = [PacketRefId] -> [PktWithWireRep] -> [PktWithWireRep]
go []
  where
    go :: [PacketRefId] -> [PktWithWireRep] -> [PktWithWireRep]
go [PacketRefId]
_ [] = []
    go [PacketRefId]
seen (PktWithWireRep
pkt:[PktWithWireRep]
rest) =
      let packetRefId :: PacketRefId
packetRefId = PktWithWireRep -> PacketRefId
packetRefIdOf PktWithWireRep
pkt
       in if PacketRefId
packetRefId PacketRefId -> [PacketRefId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PacketRefId]
seen
            then [PacketRefId] -> [PktWithWireRep] -> [PktWithWireRep]
go [PacketRefId]
seen [PktWithWireRep]
rest
            else PktWithWireRep
pkt PktWithWireRep -> [PktWithWireRep] -> [PktWithWireRep]
forall a. a -> [a] -> [a]
: [PacketRefId] -> [PktWithWireRep] -> [PktWithWireRep]
go (PacketRefId
packetRefId PacketRefId -> [PacketRefId] -> [PacketRefId]
forall a. a -> [a] -> [a]
: [PacketRefId]
seen) [PktWithWireRep]
rest

selectPacketRefsByValue :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep]
selectPacketRefsByValue :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep]
selectPacketRefsByValue [Pkt]
expected [PktWithWireRep]
available = [Pkt] -> [PktWithWireRep] -> [PktWithWireRep] -> [PktWithWireRep]
go [Pkt]
expected [PktWithWireRep]
available []
  where
    go :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep] -> [PktWithWireRep]
go [] [PktWithWireRep]
_ [PktWithWireRep]
acc = [PktWithWireRep] -> [PktWithWireRep]
forall a. [a] -> [a]
reverse [PktWithWireRep]
acc
    go (Pkt
pkt:[Pkt]
pktRest) [PktWithWireRep]
refs [PktWithWireRep]
acc =
      case Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep])
extractFirstByValue Pkt
pkt [PktWithWireRep]
refs of
        Maybe (PktWithWireRep, [PktWithWireRep])
Nothing ->
          String -> [PktWithWireRep]
forall a. HasCallStack => String -> a
error
            (String
"TKWithWireRep Semigroup merge missing packet reference for tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++
             Word8 -> String
forall a. Show a => a -> String
show (Pkt -> Word8
pktTag Pkt
pkt))
        Just (PktWithWireRep
matched, [PktWithWireRep]
remaining) -> [Pkt] -> [PktWithWireRep] -> [PktWithWireRep] -> [PktWithWireRep]
go [Pkt]
pktRest [PktWithWireRep]
remaining (PktWithWireRep
matched PktWithWireRep -> [PktWithWireRep] -> [PktWithWireRep]
forall a. a -> [a] -> [a]
: [PktWithWireRep]
acc)

extractFirstByValue :: Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep])
extractFirstByValue :: Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep])
extractFirstByValue Pkt
_ [] = Maybe (PktWithWireRep, [PktWithWireRep])
forall a. Maybe a
Nothing
extractFirstByValue Pkt
expected (PktWithWireRep
pkt:[PktWithWireRep]
rest)
  | PktWithWireRep -> Pkt
_pktValue PktWithWireRep
pkt Pkt -> Pkt -> Bool
forall a. Eq a => a -> a -> Bool
== Pkt
expected = (PktWithWireRep, [PktWithWireRep])
-> Maybe (PktWithWireRep, [PktWithWireRep])
forall a. a -> Maybe a
Just (PktWithWireRep
pkt, [PktWithWireRep]
rest)
  | Bool
otherwise = ([PktWithWireRep] -> [PktWithWireRep])
-> (PktWithWireRep, [PktWithWireRep])
-> (PktWithWireRep, [PktWithWireRep])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (PktWithWireRep
pkt PktWithWireRep -> [PktWithWireRep] -> [PktWithWireRep]
forall a. a -> [a] -> [a]
:) ((PktWithWireRep, [PktWithWireRep])
 -> (PktWithWireRep, [PktWithWireRep]))
-> Maybe (PktWithWireRep, [PktWithWireRep])
-> Maybe (PktWithWireRep, [PktWithWireRep])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep])
extractFirstByValue Pkt
expected [PktWithWireRep]
rest

-- | Extract all SomePKPayloads from a TK (primary + subkeys) without biplate
tkPKPayloads :: TK k -> [SomePKPayload]
tkPKPayloads :: forall (k :: TKKind). TK k -> [SomePKPayload]
tkPKPayloads TK k
tk =
  KeyPkt (TKKindToKeyPktKind k) -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload (TK k -> KeyPkt (TKKindToKeyPktKind k)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK k
tk) SomePKPayload -> [SomePKPayload] -> [SomePKPayload]
forall a. a -> [a] -> [a]
:
  ((KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])
 -> SomePKPayload)
-> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
-> [SomePKPayload]
forall a b. (a -> b) -> [a] -> [b]
map (KeyPkt (TKKindToKeyPktKind k) -> SomePKPayload
forall (k :: KeyPktKind). KeyPkt k -> SomePKPayload
keyPktPKPayload (KeyPkt (TKKindToKeyPktKind k) -> SomePKPayload)
-> ((KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])
    -> KeyPkt (TKKindToKeyPktKind k))
-> (KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])
-> SomePKPayload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])
-> KeyPkt (TKKindToKeyPktKind k)
forall a b. (a, b) -> a
fst) (TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
forall (k :: TKKind).
TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
_tkSubs TK k
tk)

-- | Index public TKs by key ID, fingerprint, and UID
instance Indexable KeyringIxs (TK 'PublicTK) where
  indices :: IxList KeyringIxs (TK 'PublicTK)
indices = Ix EightOctetKeyId (TK 'PublicTK)
-> Ix Fingerprint (TK 'PublicTK)
-> Ix Text (TK 'PublicTK)
-> IxList KeyringIxs (TK 'PublicTK)
forall (ixs :: [*]) a r. MkIxList ixs ixs a r => r
ixList ((TK 'PublicTK -> [EightOctetKeyId])
-> Ix EightOctetKeyId (TK 'PublicTK)
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TK 'PublicTK -> [EightOctetKeyId]
getEOKIsPublic) ((TK 'PublicTK -> [Fingerprint]) -> Ix Fingerprint (TK 'PublicTK)
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TK 'PublicTK -> [Fingerprint]
getFingerprintsPublic) ((TK 'PublicTK -> [Text]) -> Ix Text (TK 'PublicTK)
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TK 'PublicTK -> [Text]
getUIDsPublic)

getEOKIsPublic :: TK 'PublicTK -> [EightOctetKeyId]
getEOKIsPublic :: TK 'PublicTK -> [EightOctetKeyId]
getEOKIsPublic TK 'PublicTK
tk = [Either String EightOctetKeyId] -> [EightOctetKeyId]
forall a b. [Either a b] -> [b]
rights ((SomePKPayload -> Either String EightOctetKeyId)
-> [SomePKPayload] -> [Either String EightOctetKeyId]
forall a b. (a -> b) -> [a] -> [b]
map SomePKPayload -> Either String EightOctetKeyId
eightOctetKeyID (TK 'PublicTK -> [SomePKPayload]
forall (k :: TKKind). TK k -> [SomePKPayload]
tkPKPayloads TK 'PublicTK
tk))

getFingerprintsPublic :: TK 'PublicTK -> [Fingerprint]
getFingerprintsPublic :: TK 'PublicTK -> [Fingerprint]
getFingerprintsPublic TK 'PublicTK
tk = (SomePKPayload -> Fingerprint) -> [SomePKPayload] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map SomePKPayload -> Fingerprint
fingerprint (TK 'PublicTK -> [SomePKPayload]
forall (k :: TKKind). TK k -> [SomePKPayload]
tkPKPayloads TK 'PublicTK
tk)

getUIDsPublic :: TK 'PublicTK -> [Text]
getUIDsPublic :: TK 'PublicTK -> [Text]
getUIDsPublic TK 'PublicTK
tk = (TK 'PublicTK
tk TK 'PublicTK
-> Getting
     [(Text, [SignaturePayload])]
     (TK 'PublicTK)
     [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])]
  (TK 'PublicTK)
  [(Text, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(Text, [SignaturePayload])] -> f [(Text, [SignaturePayload])])
-> TK k -> f (TK k)
tkUIDs) [(Text, [SignaturePayload])]
-> Getting (Endo [Text]) [(Text, [SignaturePayload])] Text
-> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Text, [SignaturePayload])
 -> Const (Endo [Text]) (Text, [SignaturePayload]))
-> [(Text, [SignaturePayload])]
-> Const (Endo [Text]) [(Text, [SignaturePayload])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int [(Text, [SignaturePayload])] (Text, [SignaturePayload])
folded (((Text, [SignaturePayload])
  -> Const (Endo [Text]) (Text, [SignaturePayload]))
 -> [(Text, [SignaturePayload])]
 -> Const (Endo [Text]) [(Text, [SignaturePayload])])
-> ((Text -> Const (Endo [Text]) Text)
    -> (Text, [SignaturePayload])
    -> Const (Endo [Text]) (Text, [SignaturePayload]))
-> Getting (Endo [Text]) [(Text, [SignaturePayload])] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> (Text, [SignaturePayload])
-> Const (Endo [Text]) (Text, [SignaturePayload])
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Text, [SignaturePayload]) (Text, [SignaturePayload]) Text Text
_1

-- | Index secret TKs by key ID, fingerprint, and UID
instance Indexable KeyringIxs (TK 'SecretTK) where
  indices :: IxList KeyringIxs (TK 'SecretTK)
indices = Ix EightOctetKeyId (TK 'SecretTK)
-> Ix Fingerprint (TK 'SecretTK)
-> Ix Text (TK 'SecretTK)
-> IxList KeyringIxs (TK 'SecretTK)
forall (ixs :: [*]) a r. MkIxList ixs ixs a r => r
ixList ((TK 'SecretTK -> [EightOctetKeyId])
-> Ix EightOctetKeyId (TK 'SecretTK)
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TK 'SecretTK -> [EightOctetKeyId]
getEOKIsSecret) ((TK 'SecretTK -> [Fingerprint]) -> Ix Fingerprint (TK 'SecretTK)
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TK 'SecretTK -> [Fingerprint]
getFingerprintsSecret) ((TK 'SecretTK -> [Text]) -> Ix Text (TK 'SecretTK)
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun TK 'SecretTK -> [Text]
getUIDsSecret)

getEOKIsSecret :: TK 'SecretTK -> [EightOctetKeyId]
getEOKIsSecret :: TK 'SecretTK -> [EightOctetKeyId]
getEOKIsSecret TK 'SecretTK
tk = [Either String EightOctetKeyId] -> [EightOctetKeyId]
forall a b. [Either a b] -> [b]
rights ((SomePKPayload -> Either String EightOctetKeyId)
-> [SomePKPayload] -> [Either String EightOctetKeyId]
forall a b. (a -> b) -> [a] -> [b]
map SomePKPayload -> Either String EightOctetKeyId
eightOctetKeyID (TK 'SecretTK -> [SomePKPayload]
forall (k :: TKKind). TK k -> [SomePKPayload]
tkPKPayloads TK 'SecretTK
tk))

getFingerprintsSecret :: TK 'SecretTK -> [Fingerprint]
getFingerprintsSecret :: TK 'SecretTK -> [Fingerprint]
getFingerprintsSecret TK 'SecretTK
tk = (SomePKPayload -> Fingerprint) -> [SomePKPayload] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map SomePKPayload -> Fingerprint
fingerprint (TK 'SecretTK -> [SomePKPayload]
forall (k :: TKKind). TK k -> [SomePKPayload]
tkPKPayloads TK 'SecretTK
tk)

getUIDsSecret :: TK 'SecretTK -> [Text]
getUIDsSecret :: TK 'SecretTK -> [Text]
getUIDsSecret TK 'SecretTK
tk = (TK 'SecretTK
tk TK 'SecretTK
-> Getting
     [(Text, [SignaturePayload])]
     (TK 'SecretTK)
     [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])]
  (TK 'SecretTK)
  [(Text, [SignaturePayload])]
forall (k :: TKKind) (f :: * -> *).
Functor f =>
([(Text, [SignaturePayload])] -> f [(Text, [SignaturePayload])])
-> TK k -> f (TK k)
tkUIDs) [(Text, [SignaturePayload])]
-> Getting (Endo [Text]) [(Text, [SignaturePayload])] Text
-> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Text, [SignaturePayload])
 -> Const (Endo [Text]) (Text, [SignaturePayload]))
-> [(Text, [SignaturePayload])]
-> Const (Endo [Text]) [(Text, [SignaturePayload])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int [(Text, [SignaturePayload])] (Text, [SignaturePayload])
folded (((Text, [SignaturePayload])
  -> Const (Endo [Text]) (Text, [SignaturePayload]))
 -> [(Text, [SignaturePayload])]
 -> Const (Endo [Text]) [(Text, [SignaturePayload])])
-> ((Text -> Const (Endo [Text]) Text)
    -> (Text, [SignaturePayload])
    -> Const (Endo [Text]) (Text, [SignaturePayload]))
-> Getting (Endo [Text]) [(Text, [SignaturePayload])] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> (Text, [SignaturePayload])
-> Const (Endo [Text]) (Text, [SignaturePayload])
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Text, [SignaturePayload]) (Text, [SignaturePayload]) Text Text
_1


instance Semigroup (TK k) where
  TK k
a <> :: TK k -> TK k -> TK k
<> TK k
b =
    KeyPkt (TKKindToKeyPktKind k)
-> [SignaturePayload]
-> [(Text, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
-> TK k
forall (k :: TKKind).
KeyPkt (TKKindToKeyPktKind k)
-> [SignaturePayload]
-> [(Text, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
-> TK k
TK
      (TK k -> KeyPkt (TKKindToKeyPktKind k)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK k
a)
      ([SignaturePayload] -> [SignaturePayload]
forall a. Eq a => [a] -> [a]
nub ([SignaturePayload] -> [SignaturePayload])
-> ([SignaturePayload] -> [SignaturePayload])
-> [SignaturePayload]
-> [SignaturePayload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SignaturePayload] -> [SignaturePayload]
forall a. Ord a => [a] -> [a]
sort ([SignaturePayload] -> [SignaturePayload])
-> [SignaturePayload] -> [SignaturePayload]
forall a b. (a -> b) -> a -> b
$ TK k -> [SignaturePayload]
forall (k :: TKKind). TK k -> [SignaturePayload]
_tkRevs TK k
a [SignaturePayload] -> [SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a] -> [a]
++ TK k -> [SignaturePayload]
forall (k :: TKKind). TK k -> [SignaturePayload]
_tkRevs TK k
b)
      (([(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]
forall {k} {a}.
(Ord k, Ord a) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge ([(Text, [SignaturePayload])]
 -> [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])])
-> (TK k -> [(Text, [SignaturePayload])])
-> TK k
-> TK k
-> [(Text, [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TK k -> [(Text, [SignaturePayload])]
forall (k :: TKKind). TK k -> [(Text, [SignaturePayload])]
_tkUIDs) TK k
a TK k
b)
      (([([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall {k} {a}.
(Ord k, Ord a) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge ([([UserAttrSubPacket], [SignaturePayload])]
 -> [([UserAttrSubPacket], [SignaturePayload])]
 -> [([UserAttrSubPacket], [SignaturePayload])])
-> (TK k -> [([UserAttrSubPacket], [SignaturePayload])])
-> TK k
-> TK k
-> [([UserAttrSubPacket], [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TK k -> [([UserAttrSubPacket], [SignaturePayload])]
forall (k :: TKKind).
TK k -> [([UserAttrSubPacket], [SignaturePayload])]
_tkUAts) TK k
a TK k
b)
      (([(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
-> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
-> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
forall {a} {k}.
(Ord a, Hashable k) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
ukvmerge ([(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
 -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
 -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])])
-> (TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])])
-> TK k
-> TK k
-> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
forall (k :: TKKind).
TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
_tkSubs) TK k
a TK k
b)
    where
      kvmerge :: [(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge [(k, [a])]
x [(k, [a])]
y =
        Map k [a] -> [(k, [a])]
forall k a. Map k a -> [(k, a)]
Map.toList (([a] -> [a] -> [a]) -> Map k [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [a] -> [a] -> [a]
forall {a}. Ord a => [a] -> [a] -> [a]
nsa ([(k, [a])] -> Map k [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, [a])]
x) ([(k, [a])] -> Map k [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, [a])]
y))
      ukvmerge :: [(k, [a])] -> [(k, [a])] -> [(k, [a])]
ukvmerge [(k, [a])]
x [(k, [a])]
y =
        HashMap k [a] -> [(k, [a])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList
          (([a] -> [a] -> [a])
-> HashMap k [a] -> HashMap k [a] -> HashMap k [a]
forall k v.
Eq k =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith [a] -> [a] -> [a]
forall {a}. Ord a => [a] -> [a] -> [a]
nsa ([(k, [a])] -> HashMap k [a]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(k, [a])]
x) ([(k, [a])] -> HashMap k [a]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(k, [a])]
y))
      nsa :: [a] -> [a] -> [a]
nsa [a]
x [a]
y = [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
y