    -- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys
    -- Copyright © 2012-2015  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, 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(..), ixList, ixFun)
    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
                    (ixFun getEOKIs)
                    (ixFun getTOFs)
                    (ixFun getUIDs)

    getEOKIs :: TK -> [EightOctetKeyId]
    getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [PKPayload]))
    getTOFs :: TK -> [TwentyOctetFingerprint]
    getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload])
    getUIDs :: TK -> [Text]
    getUIDs tk = (tk^.tkUIDs)^..folded._1

    instance Ord SignaturePayload where
        compare s1@(SigV3 st1 ct1 eoki1 pka1 ha1 left16_1 mpis1) s2@(SigV3 st2 ct2 eoki2 pka2 ha2 left16_2 mpis2) = compare ct1 ct2 <> compare st1 st2 <> compare eoki1 eoki2 -- FIXME: nondeterministic
        compare s1@(SigV4 st1 pka1 ha1 has1 uhas1 left16_1 mpis1) s2@(SigV4 st2 pka2 ha2 has2 uhas2 left16_2 mpis2) = compare (sigCT s1) (sigCT s2) <> compare st1 st2 <> compare (issuer (SignaturePkt s1)) (issuer (SignaturePkt s2)) -- FIXME: nondeterministic
        compare s1@(SigVOther sv1 bs1) s2@(SigVOther sv2 bs2) = compare sv1 sv2 <> compare bs1 bs2
        compare (SigV3 {}) (SigV4 {}) = LT
        compare (SigV3 {}) (SigVOther {}) = LT
        compare (SigV4 {}) (SigV3 {}) = GT
        compare (SigV4 {}) (SigVOther {}) = LT
        compare (SigVOther {}) (SigV3 {}) = GT
        compare (SigVOther {}) (SigV4 {}) = GT

    instance Semigroup TK where
        (<>) a b = TK (_tkKey a)
                      (nub . sort $ _tkRevs a ++ _tkRevs b)
                      ((kvmerge `on` _tkUIDs) a b)
                      ((kvmerge `on` _tkUAts) a b)
                      ((ukvmerge `on` _tkSubs) a b)
          where
            kvmerge x y = Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y))
            ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y))
            nsa x y = nub . sort $ x ++ y