-- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys
-- Copyright © 2012-2019  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# 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.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.Map as Map
import Data.Semigroup (Semigroup, (<>))
import Data.Text (Text)

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

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

getTOFs :: TK -> [TwentyOctetFingerprint]
getTOFs :: TK -> [TwentyOctetFingerprint]
getTOFs tk :: TK
tk = (PKPayload -> TwentyOctetFingerprint)
-> [PKPayload] -> [TwentyOctetFingerprint]
forall a b. (a -> b) -> [a] -> [b]
map PKPayload -> TwentyOctetFingerprint
fingerprint (TK
tk TK -> Getting (Endo [PKPayload]) TK PKPayload -> [PKPayload]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [PKPayload]) TK PKPayload
forall s a. (Data s, Typeable a) => Traversal' s a
biplate :: [PKPayload])

getUIDs :: TK -> [Text]
getUIDs :: TK -> [Text]
getUIDs tk :: TK
tk = (TK
tk TK
-> Getting
     [(Text, [SignaturePayload])] TK [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] TK [(Text, [SignaturePayload])]
Lens' TK [(Text, [SignaturePayload])]
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
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
_1

instance Ord SignaturePayload where
  compare :: SignaturePayload -> SignaturePayload -> Ordering
compare s1 :: SignaturePayload
s1@(SigV3 st1 :: SigType
st1 ct1 :: ThirtyTwoBitTimeStamp
ct1 eoki1 :: EightOctetKeyId
eoki1 pka1 :: PubKeyAlgorithm
pka1 ha1 :: HashAlgorithm
ha1 left16_1 :: Word16
left16_1 mpis1 :: NonEmpty MPI
mpis1) s2 :: SignaturePayload
s2@(SigV3 st2 :: SigType
st2 ct2 :: ThirtyTwoBitTimeStamp
ct2 eoki2 :: EightOctetKeyId
eoki2 pka2 :: PubKeyAlgorithm
pka2 ha2 :: HashAlgorithm
ha2 left16_2 :: Word16
left16_2 mpis2 :: NonEmpty MPI
mpis2) =
    ThirtyTwoBitTimeStamp -> ThirtyTwoBitTimeStamp -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ThirtyTwoBitTimeStamp
ct1 ThirtyTwoBitTimeStamp
ct2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> SigType -> SigType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SigType
st1 SigType
st2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> EightOctetKeyId -> EightOctetKeyId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare EightOctetKeyId
eoki1 EightOctetKeyId
eoki2 -- FIXME: nondeterministic
  compare s1 :: SignaturePayload
s1@(SigV4 st1 :: SigType
st1 pka1 :: PubKeyAlgorithm
pka1 ha1 :: HashAlgorithm
ha1 has1 :: [SigSubPacket]
has1 uhas1 :: [SigSubPacket]
uhas1 left16_1 :: Word16
left16_1 mpis1 :: NonEmpty MPI
mpis1) s2 :: SignaturePayload
s2@(SigV4 st2 :: SigType
st2 pka2 :: PubKeyAlgorithm
pka2 ha2 :: HashAlgorithm
ha2 has2 :: [SigSubPacket]
has2 uhas2 :: [SigSubPacket]
uhas2 left16_2 :: Word16
left16_2 mpis2 :: NonEmpty MPI
mpis2) =
    Maybe ThirtyTwoBitTimeStamp
-> Maybe ThirtyTwoBitTimeStamp -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SignaturePayload -> Maybe ThirtyTwoBitTimeStamp
sigCT SignaturePayload
s1) (SignaturePayload -> Maybe ThirtyTwoBitTimeStamp
sigCT SignaturePayload
s2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> SigType -> SigType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SigType
st1 SigType
st2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
    Maybe EightOctetKeyId -> Maybe EightOctetKeyId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Pkt -> Maybe EightOctetKeyId
issuer (SignaturePayload -> Pkt
SignaturePkt SignaturePayload
s1)) (Pkt -> Maybe EightOctetKeyId
issuer (SignaturePayload -> Pkt
SignaturePkt SignaturePayload
s2)) -- FIXME: nondeterministic
  compare s1 :: SignaturePayload
s1@(SigVOther sv1 :: Word8
sv1 bs1 :: ByteString
bs1) s2 :: SignaturePayload
s2@(SigVOther sv2 :: Word8
sv2 bs2 :: ByteString
bs2) =
    Word8 -> Word8 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word8
sv1 Word8
sv2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
bs1 ByteString
bs2
  compare SigV3 {} SigV4 {} = Ordering
LT
  compare SigV3 {} SigVOther {} = Ordering
LT
  compare SigV4 {} SigV3 {} = Ordering
GT
  compare SigV4 {} SigVOther {} = Ordering
LT
  compare SigVOther {} SigV3 {} = Ordering
GT
  compare SigVOther {} SigV4 {} = Ordering
GT

instance Semigroup TK where
  <> :: TK -> TK -> TK
(<>) a :: TK
a b :: TK
b =
    (PKPayload, Maybe SKAddendum)
-> [SignaturePayload]
-> [(Text, [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [(Pkt, [SignaturePayload])]
-> TK
TK
      (TK -> (PKPayload, Maybe SKAddendum)
_tkKey TK
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 -> [SignaturePayload]
_tkRevs TK
a [SignaturePayload] -> [SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a] -> [a]
++ TK -> [SignaturePayload]
_tkRevs TK
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 -> [(Text, [SignaturePayload])])
-> TK
-> TK
-> [(Text, [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TK -> [(Text, [SignaturePayload])]
_tkUIDs) TK
a TK
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 -> [([UserAttrSubPacket], [SignaturePayload])])
-> TK
-> TK
-> [([UserAttrSubPacket], [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TK -> [([UserAttrSubPacket], [SignaturePayload])]
_tkUAts) TK
a TK
b)
      (([(Pkt, [SignaturePayload])]
-> [(Pkt, [SignaturePayload])] -> [(Pkt, [SignaturePayload])]
forall k a.
(Hashable k, Ord a, Eq k) =>
[(k, [a])] -> [(k, [a])] -> [(k, [a])]
ukvmerge ([(Pkt, [SignaturePayload])]
 -> [(Pkt, [SignaturePayload])] -> [(Pkt, [SignaturePayload])])
-> (TK -> [(Pkt, [SignaturePayload])])
-> TK
-> TK
-> [(Pkt, [SignaturePayload])]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TK -> [(Pkt, [SignaturePayload])]
_tkSubs) TK
a TK
b)
    where
      kvmerge :: [(k, [a])] -> [(k, [a])] -> [(k, [a])]
kvmerge x :: [(k, [a])]
x y :: [(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 x :: [(k, [a])]
x y :: [(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, Hashable 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 x :: [a]
x y :: [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