-- 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 (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