Address.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module      : Haskoin.Address
-- Copyright   : No rights reserved
-- License     : MIT
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : POSIX
--
-- Base58, CashAddr, Bech32 address and WIF private key serialization support.
module Haskoin.Address
  ( -- * Addresses
    Address (..),
    isPubKeyAddress,
    isScriptAddress,
    isWitnessAddress,
    isWitnessPubKeyAddress,
    isWitnessScriptAddress,
    addrToText,
    textToAddr,
    bech32ToAddr,
    cashToAddr,
    base58ToAddr,
    pubKeyAddr,
    pubKeyWitnessAddr,
    pubKeyCompatWitnessAddr,
    p2pkhAddr,
    p2wpkhAddr,
    p2shAddr,
    p2wshAddr,
    inputAddress,
    outputAddress,
    addressToScript,
    addressToScriptBS,
    addressToOutput,
    payToScriptAddress,
    payToWitnessScriptAddress,
    payToNestedScriptAddress,
    scriptToAddress,
    scriptToAddressBS,
    module Haskoin.Address.Base58,
    module Haskoin.Address.Bech32,
    module Haskoin.Address.CashAddr,
  )
where

import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second)
import Control.DeepSeq (NFData)
import Control.Monad ((<=<))
import Crypto.Secp256k1
import Data.Aeson (ToJSON (toJSON), Value, withText)
import Data.Aeson.Encoding (Encoding, null_, text)
import Data.Aeson.Types (Encoding, Parser, ToJSON (toJSON), Value, withText)
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Bytes.Get (MonadGet (getByteString, getWord64be, getWord8), runGetS)
import Data.Bytes.Put (MonadPut (putByteString, putWord64be, putWord8), runPutS)
import Data.Bytes.Serial (Serial (..))
import Data.Hashable (Hashable)
import Data.Maybe (isNothing)
import Data.Serialize (Serialize (..))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word8)
import GHC.Generics (Generic)
import Haskoin.Address.Base58
import Haskoin.Address.Bech32
import Haskoin.Address.CashAddr
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Network.Data
import Haskoin.Script.Common
import Haskoin.Script.Standard
import Haskoin.Util

-- | Address format for Bitcoin and Bitcoin Cash.
data Address
  = -- | pay to public key hash (regular)
    PubKeyAddress
      { -- | RIPEMD160 hash of public key's SHA256 hash
        hash160 :: !Hash160
      }
  | -- | pay to script hash
    ScriptAddress
      { -- | RIPEMD160 hash of script's SHA256 hash
        hash160 :: !Hash160
      }
  | -- | pay to witness public key hash
    WitnessPubKeyAddress
      { -- | RIPEMD160 hash of public key's SHA256 hash
        hash160 :: !Hash160
      }
  | -- | pay to witness script hash
    WitnessScriptAddress
      { -- | HASH256 hash of script
        hash256 :: !Hash256
      }
  | -- | other witness address
    WitnessAddress
      { version :: !Word8,
        bytes :: !ByteString
      }
  deriving
    (Eq, Ord, Generic, Show, Read, Hashable, NFData)

instance Serial Address where
  serialize (PubKeyAddress k) = do
    putWord8 0x00
    serialize k
  serialize (ScriptAddress s) = do
    putWord8 0x01
    serialize s
  serialize (WitnessPubKeyAddress h) = do
    putWord8 0x02
    serialize h
  serialize (WitnessScriptAddress s) = do
    putWord8 0x03
    serialize s
  serialize (WitnessAddress v d) = do
    putWord8 0x04
    putWord8 v
    putWord64be (fromIntegral (B.length d))
    putByteString d

  deserialize =
    getWord8 >>= \case
      0x00 -> PubKeyAddress <$> deserialize
      0x01 -> ScriptAddress <$> deserialize
      0x02 -> WitnessPubKeyAddress <$> deserialize
      0x03 -> WitnessScriptAddress <$> deserialize
      0x04 ->
        WitnessAddress
          <$> getWord8
          <*> (getByteString . fromIntegral =<< getWord64be)
      b ->
        fail . T.unpack $
          "Could not decode address type byte: "
            <> encodeHex (B.singleton b)

instance Serialize Address where
  put = serialize
  get = deserialize

instance Binary Address where
  put = serialize
  get = deserialize

-- | 'Address' pays to a public key hash.
isPubKeyAddress :: Address -> Bool
isPubKeyAddress PubKeyAddress {} = True
isPubKeyAddress _ = False

-- | 'Address' pays to a script hash.
isScriptAddress :: Address -> Bool
isScriptAddress ScriptAddress {} = True
isScriptAddress _ = False

-- | 'Address' pays to a witness public key hash. Only valid for SegWit
-- networks.
isWitnessPubKeyAddress :: Address -> Bool
isWitnessPubKeyAddress WitnessPubKeyAddress {} = True
isWitnessPubKeyAddress _ = False

isWitnessScriptAddress :: Address -> Bool
isWitnessScriptAddress WitnessScriptAddress {} = True
isWitnessScriptAddress _ = False

isWitnessAddress :: Address -> Bool
isWitnessAddress WitnessAddress {} = True
isWitnessAddress _ = False

instance MarshalJSON Network Address where
  marshalValue net a = toJSON (addrToText net a)
  marshalEncoding net = maybe null_ text . addrToText net
  unmarshalValue net =
    withText "address" $ \t ->
      case textToAddr net t of
        Nothing -> fail "could not decode address"
        Just x -> return x

-- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or
-- 'CashAddr' depending on network.
addrToText :: Network -> Address -> Maybe Text
addrToText net a@PubKeyAddress {hash160 = h}
  | isNothing net.cashAddrPrefix =
      Just . encodeBase58Check . runPutS $ base58put net a
  | otherwise = cashAddrEncode net 0 (runPutS $ serialize h)
addrToText net a@ScriptAddress {hash160 = h}
  | isNothing net.cashAddrPrefix =
      Just . encodeBase58Check . runPutS $ base58put net a
  | otherwise =
      cashAddrEncode net 1 (runPutS $ serialize h)
addrToText net WitnessPubKeyAddress {hash160 = h} = do
  hrp <- net.bech32Prefix
  segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
addrToText net WitnessScriptAddress {hash256 = h} = do
  hrp <- net.bech32Prefix
  segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
addrToText net WitnessAddress {version = v, bytes = d} = do
  hrp <- net.bech32Prefix
  segwitEncode hrp v (B.unpack d)

-- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network.
textToAddr :: Network -> Text -> Maybe Address
textToAddr net txt =
  cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr net txt

cashToAddr :: Network -> Text -> Maybe Address
cashToAddr net txt = do
  (ver, bs) <- cashAddrDecode net txt
  case ver of
    0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
    1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
    _ -> Nothing

bech32ToAddr :: Network -> Text -> Maybe Address
bech32ToAddr net txt = do
  hrp <- net.bech32Prefix
  (ver, bs) <- second B.pack <$> segwitDecode hrp txt
  case ver of
    0 -> case B.length bs of
      20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
      32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
      _ -> Nothing
    _ -> Just $ WitnessAddress ver bs

base58ToAddr :: Network -> Text -> Maybe Address
base58ToAddr net txt =
  eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt

base58get :: (MonadGet m) => Network -> m Address
base58get net = do
  pfx <- getWord8
  addr <- deserialize
  f pfx addr
  where
    f x a
      | x == net.addrPrefix = return $ PubKeyAddress a
      | x == net.scriptPrefix = return $ ScriptAddress a
      | otherwise = fail "Does not recognize address prefix"

base58put :: (MonadPut m) => Network -> Address -> m ()
base58put net (PubKeyAddress h) = do
  putWord8 net.addrPrefix
  serialize h
base58put net (ScriptAddress h) = do
  putWord8 net.scriptPrefix
  serialize h
base58put _ _ = error "Cannot serialize this address as Base58"

-- | Obtain a standard pay-to-public-key-hash address from a public key.
pubKeyAddr :: Ctx -> PublicKey -> Address
pubKeyAddr ctx = PubKeyAddress . addressHash . marshal ctx

-- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'.
p2pkhAddr :: Hash160 -> Address
p2pkhAddr = PubKeyAddress

-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
-- public key.
pubKeyWitnessAddr :: Ctx -> PublicKey -> Address
pubKeyWitnessAddr ctx =
  WitnessPubKeyAddress . addressHash . marshal ctx

-- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key.
pubKeyCompatWitnessAddr :: Ctx -> PublicKey -> Address
pubKeyCompatWitnessAddr ctx =
  p2shAddr
    . addressHash
    . marshal ctx
    . PayWitnessPKHash
    . addressHash
    . marshal ctx

-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
-- 'Hash160'.
p2wpkhAddr :: Hash160 -> Address
p2wpkhAddr = WitnessPubKeyAddress

-- | Obtain a standard pay-to-script-hash (P2SH) address from a 'Hash160'.
p2shAddr :: Hash160 -> Address
p2shAddr = ScriptAddress

-- | Obtain a SegWit pay-to-witness-script-hash (P2WSH) address from a 'Hash256'
p2wshAddr :: Hash256 -> Address
p2wshAddr = WitnessScriptAddress

-- | Compute a standard pay-to-script-hash (P2SH) address for an output script.
payToScriptAddress :: Ctx -> ScriptOutput -> Address
payToScriptAddress ctx = p2shAddr . addressHash . marshal ctx

-- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output
-- script.
payToWitnessScriptAddress :: Ctx -> ScriptOutput -> Address
payToWitnessScriptAddress ctx = p2wshAddr . sha256 . marshal ctx

-- | Compute a backwards-compatible SegWit P2SH-P2WSH address.
payToNestedScriptAddress :: Ctx -> ScriptOutput -> Address
payToNestedScriptAddress ctx =
  p2shAddr . addressHash . marshal ctx . toP2WSH . encodeOutput ctx

-- | Encode an output script from an address. Will fail if using a
-- pay-to-witness address on a non-SegWit network.
addressToOutput :: Address -> ScriptOutput
addressToOutput =
  \case
    PubKeyAddress h -> PayPKHash h
    ScriptAddress h -> PayScriptHash h
    WitnessPubKeyAddress h -> PayWitnessPKHash h
    WitnessScriptAddress h -> PayWitnessScriptHash h
    WitnessAddress v d -> PayWitness v d

-- | Get output script AST for an 'Address'.
addressToScript :: Ctx -> Address -> Script
addressToScript ctx = encodeOutput ctx . addressToOutput

-- | Encode address as output script in 'ByteString' form.
addressToScriptBS :: Ctx -> Address -> ByteString
addressToScriptBS ctx = runPutS . serialize . addressToScript ctx

-- | Decode an output script into an 'Address' if it has such representation.
scriptToAddress :: Ctx -> Script -> Either String Address
scriptToAddress ctx =
  maybeToEither e . outputAddress ctx <=< decodeOutput ctx
  where
    e = "Could not decode address"

-- | Decode a serialized script into an 'Address'.
scriptToAddressBS :: Ctx -> ByteString -> Either String Address
scriptToAddressBS ctx =
  maybeToEither e . outputAddress ctx <=< unmarshal ctx
  where
    e = "Could not decode address"

-- | Get the 'Address' of a 'ScriptOutput'.
outputAddress :: Ctx -> ScriptOutput -> Maybe Address
outputAddress ctx =
  \case
    PayPKHash h -> Just $ PubKeyAddress h
    PayScriptHash h -> Just $ ScriptAddress h
    PayPK k -> Just $ pubKeyAddr ctx k
    PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
    PayWitnessScriptHash h -> Just $ WitnessScriptAddress h
    PayWitness v d -> Just $ WitnessAddress v d
    _ -> Nothing

-- | Infer the 'Address' of a 'ScriptInput'.
inputAddress :: Ctx -> ScriptInput -> Maybe Address
inputAddress ctx =
  \case
    (RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr ctx key
    (ScriptHashInput _ rdm) -> Just $ payToScriptAddress ctx rdm
    _ -> Nothing