-- 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 = [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 = (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
-> 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 SigType
st1 ThirtyTwoBitTimeStamp
ct1 EightOctetKeyId
eoki1 PubKeyAlgorithm
pka1 HashAlgorithm
ha1 Word16
left16_1 NonEmpty MPI
mpis1) s2 :: SignaturePayload
s2@(SigV3 SigType
st2 ThirtyTwoBitTimeStamp
ct2 EightOctetKeyId
eoki2 PubKeyAlgorithm
pka2 HashAlgorithm
ha2 Word16
left16_2 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 SigType
st1 PubKeyAlgorithm
pka1 HashAlgorithm
ha1 [SigSubPacket]
has1 [SigSubPacket]
uhas1 Word16
left16_1 NonEmpty MPI
mpis1) s2 :: SignaturePayload
s2@(SigV4 SigType
st2 PubKeyAlgorithm
pka2 HashAlgorithm
ha2 [SigSubPacket]
has2 [SigSubPacket]
uhas2 Word16
left16_2 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 Word8
sv1 ByteString
bs1) s2 :: SignaturePayload
s2@(SigVOther Word8
sv2 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
(<>) TK
a 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 [(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, 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 [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