From 311f023508db39d6a704857e90e0122f9da28571 Mon Sep 17 00:00:00 2001
From: Pawel Jakubas <pawel.jakubas@iohk.io>
Date: Mon, 16 Nov 2020 12:57:11 +0100
Subject: [PATCH] add isShared

---
 lib/core/cardano-wallet-core.cabal            |  1 +
 .../src/Cardano/Wallet/Primitive/Scripts.hs   | 85 +++++++++++++++++++
 2 files changed, 86 insertions(+)
 create mode 100644 lib/core/src/Cardano/Wallet/Primitive/Scripts.hs

diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal
index bc459669a12..25250cccc1c 100644
--- a/lib/core/cardano-wallet-core.cabal
+++ b/lib/core/cardano-wallet-core.cabal
@@ -159,6 +159,7 @@ library
       Cardano.Wallet.Primitive.CoinSelection.Random
       Cardano.Wallet.Primitive.Fee
       Cardano.Wallet.Primitive.Model
+      Cardano.Wallet.Primitive.Scripts
       Cardano.Wallet.Primitive.Types
       Cardano.Wallet.Primitive.Types.Address
       Cardano.Wallet.Primitive.Types.Coin
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Scripts.hs b/lib/core/src/Cardano/Wallet/Primitive/Scripts.hs
new file mode 100644
index 00000000000..c573547522d
--- /dev/null
+++ b/lib/core/src/Cardano/Wallet/Primitive/Scripts.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- Copyright: © 2018-2020 IOHK
+-- License: Apache-2.0
+--
+-- An implementation of wallet's verification key discovery
+-- in a script.
+
+module Cardano.Wallet.Primitive.Scripts
+    ( isShared
+    ) where
+
+import Prelude
+
+import Cardano.Address.Derivation
+    ( xpubPublicKey )
+import Cardano.Address.Script
+    ( KeyHash (..), Script (..), ScriptHash (..), toScriptHash )
+import Cardano.Crypto.Wallet
+    ( XPub )
+import Cardano.Wallet.Primitive.AddressDerivation
+    ( Depth (..)
+    , DerivationType (..)
+    , Index (..)
+    , Role (..)
+    , SoftDerivation (..)
+    , hex
+    )
+import Cardano.Wallet.Primitive.AddressDerivation.Shelley
+    ( ShelleyKey (..) )
+import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
+    ( SeqState (..), accountPubKey )
+import Crypto.Hash.Utils
+    ( blake2b224 )
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Text.Encoding as T
+
+instance Ord ScriptHash where
+    compare (ScriptHash sh1) (ScriptHash sh2) =
+        compare (T.decodeUtf8 $ hex sh1) (T.decodeUtf8 $ hex sh2)
+
+isShared
+    :: (k ~ ShelleyKey, SoftDerivation k)
+    => Script
+    -> SeqState n k
+    -> ([k 'ScriptK XPub], SeqState n k)
+isShared script s@(SeqState !s1 !s2 !ixs !rpk !prefix !scripts) =
+    let verKeysInScript = extractVerKey [] script
+        toVerKey = deriveAddressPublicKey (accountPubKey s2) MultisigScript
+        minIndex = getIndex @'Soft minBound
+        scriptAddressGap = 10
+        toKeyHash = KeyHash . blake2b224 . xpubPublicKey . getKey
+        ourVerKeyHashes =
+            map (\ix -> toVerKey (toEnum (fromInteger $ toInteger $ minIndex + ix)))
+            [0 .. scriptAddressGap - 1]
+        ourVerKeysInScript =
+            filter (\keyH -> toKeyHash keyH `elem` verKeysInScript)
+            ourVerKeyHashes
+        toScriptXPub (ShelleyKey k) = ShelleyKey k
+        scriptXPubs = map toScriptXPub ourVerKeysInScript
+    in if null ourVerKeysInScript then
+        ([], s)
+       else
+        ( scriptXPubs
+        , SeqState s1 s2 ixs rpk prefix (Map.insert (toScriptHash script) scriptXPubs scripts))
+  where
+    extractVerKey acc (RequireSignatureOf verKey) = verKey : acc
+    extractVerKey acc (RequireAllOf xs) = foldr (flip extractVerKey) acc xs
+    extractVerKey acc (RequireAnyOf xs) = foldr (flip extractVerKey) acc xs
+    extractVerKey acc (RequireSomeOf _ xs) = foldr (flip extractVerKey) acc xs