Add additional wallet primitives and wallet layer primitives

cardano-wallet.cabal

@@ -28,20 +28,16 @@ library
       -Wall
       -Wcompat
       -fwarn-redundant-constraints
-
   if (!flag(development))
     ghc-options:         -Werror
-
   build-depends:
       base
-
-    -- Hackage Dependencies
     , bytestring
     , cborg
     , containers
     , deepseq
     , text
-
+    , transformers
   hs-source-dirs:
       src
   exposed-modules:
@@ -62,15 +58,14 @@ executable cardano-wallet-server
       -threaded -rtsopts
       -Wall
       -O2
-
   build-depends:
       base
-
   hs-source-dirs:
       app/server
   main-is:
       Main.hs
 
+
 test-suite unit
   default-language:
       Haskell2010
@@ -81,14 +76,11 @@ test-suite unit
       -threaded -rtsopts
       -Wall
       -O2
-
   if (!flag(development))
     ghc-options:         -Werror
-
   build-depends:
       base
     , cardano-wallet
-
     , base58-bytestring
     , bytestring
     , cborg

src/Cardano/Wallet/Primitive.hs

@@ -2,7 +2,10 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- |
 -- Copyright: © 2018-2019 IOHK
@@ -24,15 +27,24 @@ module Cardano.Wallet.Primitive
     , Tx(..)
     , TxIn(..)
     , TxOut(..)
+    , txId
+    , txIns
+    , txOutsOurs
+    , updatePending
 
     -- * Address
     , Address (..)
+    , IsOurs(..)
 
     -- * Coin
     , Coin (..)
+    , isValidCoin
 
     -- * UTxO
     , UTxO (..)
+    , balance
+    , changeUTxO
+    , utxoFromTx
     , excluding
     , isSubsetOf
     , restrictedBy
@@ -47,12 +59,18 @@ import Prelude
 
 import Control.DeepSeq
     ( NFData (..) )
+import Control.Monad.Trans.State.Strict
+    ( State, runState, state )
 import Data.ByteString
     ( ByteString )
 import Data.Map.Strict
     ( Map )
+import Data.Maybe
+    ( catMaybes )
 import Data.Set
     ( Set )
+import Data.Traversable
+    ( for )
 import Data.Word
     ( Word16, Word32, Word64 )
 import GHC.Generics
@@ -101,15 +119,48 @@ data Tx = Tx
         -- ^ Order of outputs matter in the transaction representations. Outputs
         -- are used as inputs for next transactions which refer to them using
         -- their indexes. It matters also for serialization.
-    } deriving (Show, Eq, Ord, Generic)
+    } deriving (Show, Generic, Ord, Eq)
 
 instance NFData Tx
 
+-- | Calculating a transaction id. Assumed to be effectively injective
+txId :: Tx -> Hash "Tx"
+txId = error
+    "txId: not yet implemented. We need the ability to encode a Tx to CBOR for:\
+    \ BA.convert . hash @_ @Blake2b_256 . CBOR.toStrictByteString . encodeTx"
+
+txIns :: Set Tx -> Set TxIn
+txIns =
+    foldMap (Set.fromList . inputs)
+
+txOutsOurs
+    :: forall s. (IsOurs s)
+    => Set Tx
+    -> s
+    -> (Set TxOut, s)
+txOutsOurs txs =
+    runState $ Set.fromList <$> forMaybe (foldMap outputs txs) pick
+  where
+    pick :: TxOut -> State s (Maybe TxOut)
+    pick out = do
+        predicate <- state $ isOurs (address out)
+        return $ if predicate then Just out else Nothing
+
+    forMaybe :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]
+    forMaybe xs = fmap catMaybes . for xs
+
+updatePending :: Block -> Set Tx -> Set Tx
+updatePending b =
+    let
+        isStillPending ins = Set.null . Set.intersection ins . Set.fromList . inputs
+    in
+        Set.filter (isStillPending (txIns $ transactions b))
+
 
 data TxIn = TxIn
-    { txId
+    { inputId
         :: !(Hash "Tx")
-    , txIx
+    , inputIx
         :: !Word32
     } deriving (Show, Generic, Eq, Ord)
 
@@ -134,37 +185,40 @@ newtype Address = Address
 
 instance NFData Address
 
+-- | This abstraction exists to give us the ability to keep the wallet business
+-- logic agnostic to the address derivation and discovery mechanisms.
+--
+-- This is needed because two different address schemes lives on Cardano:
+--   - A hierarchical random scheme:
+--      rather 'custom' made, with several flaws; this is the original and now
+--      legacy address scheme.
+--
+--   - A hierarchical sequential scheme:
+--      a new scheme based on the BIP-0044 specification, which is better suited
+--      for our present needs.
+--
+-- In practice, we will need a wallet that can support both, even if not at the
+-- same time, and this little abstraction can buy us this without introducing
+-- too much overhead.
+class IsOurs s where
+    isOurs :: Address -> s -> (Bool, s)
+
 
 -- * Coin
 
 -- | Coins are stored as Lovelace (reminder: 1 Lovelace = 1e6 ADA)
 newtype Coin = Coin
     { getCoin :: Word64
     } deriving stock (Show, Ord, Eq, Generic)
-      deriving newtype (Enum, Num, Real, Integral)
 
 instance NFData Coin
 
 instance Bounded Coin where
     minBound = Coin 0
     maxBound = Coin 45000000000000000
 
-instance Semigroup Coin where
-    (Coin a) <> (Coin b) =
-        invariant
-            ( mconcat
-                [ "Cardano.Wallet.Primitive.Coin (<>), sum out of bounds: "
-                , show a
-                , " + "
-                , show b
-                ]
-            )
-            (Coin (a + b))
-            (<= maxBound)
-
-instance Monoid Coin where
-    mempty  = minBound
-    mconcat = foldr (<>) mempty
+isValidCoin :: Coin -> Bool
+isValidCoin c = c >= minBound && c <= maxBound
 
 
 -- * UTxO
@@ -179,6 +233,25 @@ instance Dom UTxO where
     type DomElem UTxO = TxIn
     dom (UTxO utxo) = Map.keysSet utxo
 
+balance :: UTxO -> Integer
+balance =
+    Map.foldl' (\total out -> total + fromIntegral (getCoin (coin out))) 0 . getUTxO
+
+utxoFromTx :: Tx -> UTxO
+utxoFromTx tx@(Tx _ outs) =
+    UTxO $ Map.fromList $ zip (TxIn (txId tx) <$> [0..]) outs
+
+changeUTxO
+    :: IsOurs s
+    => Set Tx
+    -> s
+    -> (UTxO, s)
+changeUTxO pending = runState $ do
+    ours <- state $ txOutsOurs pending
+    let utxo = foldMap utxoFromTx pending
+    let ins = txIns pending
+    return $ (utxo `restrictedTo` ours) `restrictedBy` ins
+
 -- ins⋪ u
 excluding :: UTxO -> Set TxIn ->  UTxO
 excluding (UTxO utxo) =
@@ -200,24 +273,15 @@ restrictedTo (UTxO utxo) outs =
     UTxO $ Map.filter (`Set.member` outs) utxo
 
 
+-- * Generic
+
 class Dom a where
     type DomElem a :: *
     dom :: a -> Set (DomElem a)
 
 
--- * Helpers
-
 newtype Hash (tag :: Symbol) = Hash
     { getHash :: ByteString
     } deriving (Show, Generic, Eq, Ord)
 
 instance NFData (Hash tag)
-
-
-invariant
-    :: String
-    -> a
-    -> (a -> Bool)
-    -> a
-invariant msg a predicate =
-    if predicate a then a else error msg

test/unit/Cardano/Wallet/BinarySpec.hs

@@ -49,8 +49,8 @@ block2 = Block
         [ Tx
             { inputs =
                 [ TxIn
-                    { txId = hash16 "60dbb2679ee920540c18195a3d92ee9be50aee6ed5f891d92d51db8a76b02cd2"
-                    , txIx = 3
+                    { inputId = hash16 "60dbb2679ee920540c18195a3d92ee9be50aee6ed5f891d92d51db8a76b02cd2"
+                    , inputIx = 3
                     }
                 ]
             , outputs =
@@ -79,11 +79,11 @@ block3 = Block
         [ Tx
             { inputs =
                 [ TxIn
-                    { txId = hash16 "6967e2b5c3ad5ae07a9bd8d888f1836195a04f7a1cb4b6d083261870068fab1b"
-                    , txIx = 1}
+                    { inputId = hash16 "6967e2b5c3ad5ae07a9bd8d888f1836195a04f7a1cb4b6d083261870068fab1b"
+                    , inputIx = 1}
                 , TxIn
-                    { txId = hash16 "7064addc0968bccd7d57d2e7aa1e9c2f666d8387042483fc1e87200cfb96c8f1"
-                    , txIx = 0} ]
+                    { inputId = hash16 "7064addc0968bccd7d57d2e7aa1e9c2f666d8387042483fc1e87200cfb96c8f1"
+                    , inputIx = 0} ]
             , outputs =
                 [ TxOut
                     { address = addr58 "37btjrVyb4KBsw2f3V76ntfwqDPgyf3QmmdsrTSmCnuTGYtS9JgVXzxeQEsKjgWurKoyw9BDNEtLxWtU9znK49SC8bLTirk6YqcAESFxXJkSyXhQKL"