Common.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Haskoin.Network.Common
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

Common functions and data types related to peer-to-peer network.
-}
module Haskoin.Network.Common (
    -- * Network Data Types
    Addr (..),
    NetworkAddressTime,
    Alert (..),
    GetData (..),
    Inv (..),
    InvVector (..),
    InvType (..),
    HostAddress,
    hostToSockAddr,
    sockToHostAddress,
    NetworkAddress (..),
    NotFound (..),
    Ping (..),
    Pong (..),
    Reject (..),
    RejectCode (..),
    VarInt (..),
    VarString (..),
    Version (..),
    MessageCommand (..),
    reject,
    nodeNone,
    nodeNetwork,
    nodeGetUTXO,
    nodeBloom,
    nodeWitness,
    nodeXThin,
    commandToString,
    stringToCommand,
    putVarInt,
) where

import Control.DeepSeq
import Control.Monad (forM_, liftM2, replicateM, unless)
import Data.Binary (Binary (..))
import Data.Bits (shiftL)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 as C (replicate)
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Serialize (Serialize (..))
import Data.String
import Data.String.Conversions (cs)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import Haskoin.Crypto.Hash
import Network.Socket (SockAddr (..))
import Text.Read as R

-- | Network address with a timestamp.
type NetworkAddressTime = (Word32, NetworkAddress)

{- | Provides information about known nodes in the bitcoin network. An 'Addr'
 type is sent inside a 'Message' as a response to a 'GetAddr' message.
-}
newtype Addr = Addr
    { -- List of addresses of other nodes on the network with timestamps.
      addrList :: [NetworkAddressTime]
    }
    deriving (Eq, Show, Generic, NFData)

instance Serial Addr where
    deserialize = Addr <$> (repList =<< deserialize)
      where
        repList (VarInt c) = replicateM (fromIntegral c) action
        action = liftM2 (,) getWord32le deserialize

    serialize (Addr xs) = do
        putVarInt $ length xs
        forM_ xs $ \(a, b) -> putWord32le a >> serialize b

instance Binary Addr where
    get = deserialize
    put = serialize

instance Serialize Addr where
    get = deserialize
    put = serialize

{- | Data type describing signed messages that can be sent between bitcoin
 nodes to display important notifications to end users about the health of
 the network.
-}
data Alert = Alert
    { -- | Alert payload.
      alertPayload :: !VarString
    , -- | ECDSA signature of the payload
      alertSignature :: !VarString
    }
    deriving (Eq, Show, Read, Generic, NFData)

instance Serial Alert where
    deserialize = Alert <$> deserialize <*> deserialize
    serialize (Alert p s) = serialize p >> serialize s

instance Binary Alert where
    put = serialize
    get = deserialize

instance Serialize Alert where
    put = serialize
    get = deserialize

{- | The 'GetData' type is used to retrieve information on a specific object
 ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData'
 request is a list of 'InvVector' which represent all the hashes of objects
 that a node wants. The response to a 'GetBlock' message will be either a
 'Block' or a 'Tx' message depending on the type of the object referenced by
 the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv'
 message that contains unknown object hashes.
-}
newtype GetData = GetData
    { -- | list of object hashes
      getDataList :: [InvVector]
    }
    deriving (Eq, Show, Generic, NFData)

instance Serial GetData where
    deserialize = GetData <$> (repList =<< deserialize)
      where
        repList (VarInt c) = replicateM (fromIntegral c) deserialize

    serialize (GetData xs) = do
        putVarInt $ length xs
        forM_ xs serialize

instance Binary GetData where
    get = deserialize
    put = serialize

instance Serialize GetData where
    get = deserialize
    put = serialize

{- | 'Inv' messages are used by nodes to advertise their knowledge of new
 objects by publishing a list of hashes to a peer. 'Inv' messages can be sent
 unsolicited or in response to a 'GetBlocks' message.
-}
newtype Inv = Inv
    { -- | inventory
      invList :: [InvVector]
    }
    deriving (Eq, Show, Generic, NFData)

instance Serial Inv where
    deserialize = Inv <$> (repList =<< deserialize)
      where
        repList (VarInt c) = replicateM (fromIntegral c) deserialize

    serialize (Inv xs) = do
        putVarInt $ length xs
        forM_ xs serialize

instance Binary Inv where
    get = deserialize
    put = serialize

instance Serialize Inv where
    get = deserialize
    put = serialize

{- | Data type identifying the type of an inventory vector. SegWit types are
 only used in 'GetData' messages, not 'Inv'.
-}
data InvType
    = -- | error
      InvError
    | -- | transaction
      InvTx
    | -- | block
      InvBlock
    | -- | filtered block
      InvMerkleBlock
    | -- | segwit transaction
      InvWitnessTx
    | -- | segwit block
      InvWitnessBlock
    | -- | segwit filtered block
      InvWitnessMerkleBlock
    | -- | unknown inv type
      InvType Word32
    deriving (Eq, Show, Read, Generic, NFData)

instance Serial InvType where
    deserialize = go =<< getWord32le
      where
        go x =
            case x of
                0 -> return InvError
                1 -> return InvTx
                2 -> return InvBlock
                3 -> return InvMerkleBlock
                _
                    | x == 1 `shiftL` 30 + 1 -> return InvWitnessTx
                    | x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock
                    | x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock
                    | otherwise -> return (InvType x)
    serialize x =
        putWord32le $
            case x of
                InvError -> 0
                InvTx -> 1
                InvBlock -> 2
                InvMerkleBlock -> 3
                InvWitnessTx -> 1 `shiftL` 30 + 1
                InvWitnessBlock -> 1 `shiftL` 30 + 2
                InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3
                InvType w -> w

instance Binary InvType where
    get = deserialize
    put = serialize

instance Serialize InvType where
    get = deserialize
    put = serialize

{- | Invectory vectors represent hashes identifying objects such as a 'Block' or
 a 'Tx'. They notify other peers about new data or data they have otherwise
 requested.
-}
data InvVector = InvVector
    { -- | type of object
      invType :: !InvType
    , -- | 256-bit hash of object
      invHash :: !Hash256
    }
    deriving (Eq, Show, Generic, NFData)

instance Serial InvVector where
    deserialize = InvVector <$> deserialize <*> deserialize
    serialize (InvVector t h) = serialize t >> serialize h

instance Binary InvVector where
    get = deserialize
    put = serialize

instance Serialize InvVector where
    get = deserialize
    put = serialize

newtype HostAddress
    = HostAddress ByteString
    deriving (Eq, Show, Ord, Generic, NFData)

instance Serial HostAddress where
    serialize (HostAddress bs) = putByteString bs
    deserialize = HostAddress <$> getByteString 18

instance Binary HostAddress where
    get = deserialize
    put = serialize

instance Serialize HostAddress where
    get = deserialize
    put = serialize

{- | Data type describing a bitcoin network address. Addresses are stored in
 IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6
 addresses: <http://en.wikipedia.org/wiki/IPv6#IPv4-mapped_IPv6_addresses>.
-}
data NetworkAddress = NetworkAddress
    { -- | bitmask of services available for this address
      naServices :: !Word64
    , -- | address and port information
      naAddress :: !HostAddress
    }
    deriving (Eq, Show, Generic, NFData)

hostToSockAddr :: HostAddress -> SockAddr
hostToSockAddr (HostAddress bs) =
    case runGetS getSockAddr bs of
        Left e -> error e
        Right x -> x

sockToHostAddress :: SockAddr -> HostAddress
sockToHostAddress = HostAddress . runPutS . putSockAddr

putSockAddr :: MonadPut m => SockAddr -> m ()
putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do
    putWord32be a
    putWord32be b
    putWord32be c
    putWord32be d
    putWord16be (fromIntegral p)
putSockAddr (SockAddrInet p a) = do
    putWord32be 0x00000000
    putWord32be 0x00000000
    putWord32be 0x0000ffff
    putWord32host a
    putWord16be (fromIntegral p)
putSockAddr _ = error "Invalid address type"

getSockAddr :: MonadGet m => m SockAddr
getSockAddr = do
    a <- getWord32be
    b <- getWord32be
    c <- getWord32be
    if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff
        then do
            d <- getWord32host
            p <- getWord16be
            return $ SockAddrInet (fromIntegral p) d
        else do
            d <- getWord32be
            p <- getWord16be
            return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0

instance Serial NetworkAddress where
    deserialize = NetworkAddress <$> getWord64le <*> deserialize
    serialize (NetworkAddress s a) = putWord64le s >> serialize a

instance Binary NetworkAddress where
    get = deserialize
    put = serialize

instance Serialize NetworkAddress where
    get = deserialize
    put = serialize

{- | A 'NotFound' message is returned as a response to a 'GetData' message
 whe one of the requested objects could not be retrieved. This could happen,
 for example, if a tranasaction was requested and was not available in the
 memory pool of the receiving node.
-}
newtype NotFound = NotFound
    { -- | Inventory vectors related to this request
      notFoundList :: [InvVector]
    }
    deriving (Eq, Show, Generic, NFData)

instance Serial NotFound where
    deserialize = NotFound <$> (repList =<< deserialize)
      where
        repList (VarInt c) = replicateM (fromIntegral c) deserialize

    serialize (NotFound xs) = do
        putVarInt $ length xs
        forM_ xs serialize

instance Binary NotFound where
    get = deserialize
    put = serialize

instance Serialize NotFound where
    get = deserialize
    put = serialize

{- | A 'Ping' message is sent to bitcoin peers to check if a connection is still
 open.
-}
newtype Ping = Ping
    { -- | A random nonce used to identify the recipient of the ping
      -- request once a Pong response is received.
      pingNonce :: Word64
    }
    deriving (Eq, Show, Read, Generic, NFData)

-- | A Pong message is sent as a response to a ping message.
newtype Pong = Pong
    { -- | nonce from corresponding 'Ping'
      pongNonce :: Word64
    }
    deriving (Eq, Show, Read, Generic, NFData)

instance Serial Ping where
    deserialize = Ping <$> getWord64le
    serialize (Ping n) = putWord64le n

instance Serial Pong where
    deserialize = Pong <$> getWord64le
    serialize (Pong n) = putWord64le n

instance Binary Ping where
    get = deserialize
    put = serialize

instance Binary Pong where
    get = deserialize
    put = serialize

instance Serialize Ping where
    get = deserialize
    put = serialize

instance Serialize Pong where
    get = deserialize
    put = serialize

-- | The 'Reject' message is sent when messages are rejected by a peer.
data Reject = Reject
    { -- | type of message rejected
      rejectMessage :: !MessageCommand
    , -- | rejection code
      rejectCode :: !RejectCode
    , -- | text reason for rejection
      rejectReason :: !VarString
    , -- | extra data such as block or tx hash
      rejectData :: !ByteString
    }
    deriving (Eq, Show, Read, Generic, NFData)

-- | Rejection code associated to the 'Reject' message.
data RejectCode
    = RejectMalformed
    | RejectInvalid
    | RejectObsolete
    | RejectDuplicate
    | RejectNonStandard
    | RejectDust
    | RejectInsufficientFee
    | RejectCheckpoint
    deriving (Eq, Show, Read, Generic, NFData)

instance Serial RejectCode where
    deserialize =
        getWord8 >>= \code -> case code of
            0x01 -> return RejectMalformed
            0x10 -> return RejectInvalid
            0x11 -> return RejectObsolete
            0x12 -> return RejectDuplicate
            0x40 -> return RejectNonStandard
            0x41 -> return RejectDust
            0x42 -> return RejectInsufficientFee
            0x43 -> return RejectCheckpoint
            _ ->
                fail $
                    unwords
                        [ "Reject get: Invalid code"
                        , show code
                        ]

    serialize code = putWord8 $ case code of
        RejectMalformed -> 0x01
        RejectInvalid -> 0x10
        RejectObsolete -> 0x11
        RejectDuplicate -> 0x12
        RejectNonStandard -> 0x40
        RejectDust -> 0x41
        RejectInsufficientFee -> 0x42
        RejectCheckpoint -> 0x43

instance Binary RejectCode where
    put = serialize
    get = deserialize

instance Serialize RejectCode where
    put = serialize
    get = deserialize

-- | Convenience function to build a 'Reject' message.
reject :: MessageCommand -> RejectCode -> ByteString -> Reject
reject cmd code reason =
    Reject cmd code (VarString reason) B.empty

instance Serial Reject where
    deserialize =
        deserialize >>= \(VarString bs) ->
            Reject (stringToCommand bs)
                <$> deserialize
                <*> deserialize
                <*> maybeData
      where
        maybeData =
            isEmpty >>= \done ->
                if done
                    then return B.empty
                    else getByteString 32
    serialize (Reject cmd code reason dat) = do
        serialize $ VarString $ commandToString cmd
        serialize code
        serialize reason
        unless (B.null dat) $ putByteString dat

instance Binary Reject where
    put = serialize
    get = deserialize

instance Serialize Reject where
    put = serialize
    get = deserialize

{- | Data type representing a variable-length integer. The 'VarInt' type
 usually precedes an array or a string that can vary in length.
-}
newtype VarInt = VarInt {getVarInt :: Word64}
    deriving (Eq, Show, Read, Generic, NFData)

instance Serial VarInt where
    deserialize = VarInt <$> (getWord8 >>= go)
      where
        go 0xff = getWord64le
        go 0xfe = fromIntegral <$> getWord32le
        go 0xfd = fromIntegral <$> getWord16le
        go x = return $ fromIntegral x

    serialize (VarInt x)
        | x < 0xfd =
            putWord8 $ fromIntegral x
        | x <= 0xffff = do
            putWord8 0xfd
            putWord16le $ fromIntegral x
        | x <= 0xffffffff = do
            putWord8 0xfe
            putWord32le $ fromIntegral x
        | otherwise = do
            putWord8 0xff
            putWord64le x

instance Binary VarInt where
    put = serialize
    get = deserialize

instance Serialize VarInt where
    put = serialize
    get = deserialize

putVarInt :: (MonadPut m, Integral a) => a -> m ()
putVarInt = serialize . VarInt . fromIntegral

-- | Data type for serialization of variable-length strings.
newtype VarString = VarString {getVarString :: ByteString}
    deriving (Eq, Show, Read, Generic, NFData)

instance Serial VarString where
    deserialize = VarString <$> (readBS =<< deserialize)
      where
        readBS (VarInt len) = getByteString (fromIntegral len)

    serialize (VarString bs) = do
        putVarInt $ B.length bs
        putByteString bs

instance Binary VarString where
    put = serialize
    get = deserialize

instance Serialize VarString where
    put = serialize
    get = deserialize

{- | When a bitcoin node creates an outgoing connection to another node,
 the first message it will send is a 'Version' message. The other node
 will similarly respond with it's own 'Version' message.
-}
data Version = Version
    { -- | protocol version
      version :: !Word32
    , -- | features supported by this connection
      services :: !Word64
    , -- | unix timestamp
      timestamp :: !Word64
    , -- | network address of remote node
      addrRecv :: !NetworkAddress
    , -- | network address of sending node
      addrSend :: !NetworkAddress
    , -- | random nonce to detect connection to self
      verNonce :: !Word64
    , -- | user agent string
      userAgent :: !VarString
    , -- | height of the last block in sending node
      startHeight :: !Word32
    , -- | relay transactions flag (BIP-37)
      relay :: !Bool
    }
    deriving (Eq, Show, Generic, NFData)

instance Serial Version where
    deserialize =
        Version <$> getWord32le
            <*> getWord64le
            <*> getWord64le
            <*> deserialize
            <*> deserialize
            <*> getWord64le
            <*> deserialize
            <*> getWord32le
            <*> (go =<< isEmpty)
      where
        go True = return True
        go False = getBool

    serialize (Version v s t ar as n ua sh r) = do
        putWord32le v
        putWord64le s
        putWord64le t
        serialize ar
        serialize as
        putWord64le n
        serialize ua
        putWord32le sh
        putBool r

instance Binary Version where
    put = serialize
    get = deserialize

instance Serialize Version where
    put = serialize
    get = deserialize

-- | 0x00 is 'False', anything else is 'True'.
getBool :: MonadGet m => m Bool
getBool = go =<< getWord8
  where
    go 0 = return False
    go _ = return True

putBool :: MonadPut m => Bool -> m ()
putBool True = putWord8 1
putBool False = putWord8 0

{- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify
 the type of message present in the payload. This allows the message
 de-serialization code to know how to decode a particular message payload.
 Every valid 'Message' constructor has a corresponding 'MessageCommand'
 constructor.
-}
data MessageCommand
    = MCVersion
    | MCVerAck
    | MCAddr
    | MCInv
    | MCGetData
    | MCNotFound
    | MCGetBlocks
    | MCGetHeaders
    | MCTx
    | MCBlock
    | MCMerkleBlock
    | MCHeaders
    | MCGetAddr
    | MCFilterLoad
    | MCFilterAdd
    | MCFilterClear
    | MCPing
    | MCPong
    | MCAlert
    | MCMempool
    | MCReject
    | MCSendHeaders
    | MCOther ByteString
    deriving (Eq, Generic, NFData)

instance Show MessageCommand where
    showsPrec _ = shows . commandToString

instance Read MessageCommand where
    readPrec = do
        String str <- lexP
        return (stringToCommand (cs str))

instance Serial MessageCommand where
    deserialize = go <$> getByteString 12
      where
        go bs =
            let str = unpackCommand bs
             in stringToCommand str
    serialize mc = putByteString $ packCommand $ commandToString mc

instance Binary MessageCommand where
    put = serialize
    get = deserialize

instance Serialize MessageCommand where
    put = serialize
    get = deserialize

instance IsString MessageCommand where
    fromString str = stringToCommand (cs str)

-- | Read a 'MessageCommand' from its string representation.
stringToCommand :: ByteString -> MessageCommand
stringToCommand str = case str of
    "version" -> MCVersion
    "verack" -> MCVerAck
    "addr" -> MCAddr
    "inv" -> MCInv
    "getdata" -> MCGetData
    "notfound" -> MCNotFound
    "getblocks" -> MCGetBlocks
    "getheaders" -> MCGetHeaders
    "tx" -> MCTx
    "block" -> MCBlock
    "merkleblock" -> MCMerkleBlock
    "headers" -> MCHeaders
    "getaddr" -> MCGetAddr
    "filterload" -> MCFilterLoad
    "filteradd" -> MCFilterAdd
    "filterclear" -> MCFilterClear
    "ping" -> MCPing
    "pong" -> MCPong
    "alert" -> MCAlert
    "mempool" -> MCMempool
    "reject" -> MCReject
    "sendheaders" -> MCSendHeaders
    _ -> MCOther str

-- | Convert a 'MessageCommand' to its string representation.
commandToString :: MessageCommand -> ByteString
commandToString mc = case mc of
    MCVersion -> "version"
    MCVerAck -> "verack"
    MCAddr -> "addr"
    MCInv -> "inv"
    MCGetData -> "getdata"
    MCNotFound -> "notfound"
    MCGetBlocks -> "getblocks"
    MCGetHeaders -> "getheaders"
    MCTx -> "tx"
    MCBlock -> "block"
    MCMerkleBlock -> "merkleblock"
    MCHeaders -> "headers"
    MCGetAddr -> "getaddr"
    MCFilterLoad -> "filterload"
    MCFilterAdd -> "filteradd"
    MCFilterClear -> "filterclear"
    MCPing -> "ping"
    MCPong -> "pong"
    MCAlert -> "alert"
    MCMempool -> "mempool"
    MCReject -> "reject"
    MCSendHeaders -> "sendheaders"
    MCOther c -> c

-- | Pack a string 'MessageCommand' so that it is exactly 12-bytes long.
packCommand :: ByteString -> ByteString
packCommand s =
    B.take 12 $
        s `mappend` C.replicate 12 '\NUL'

-- | Undo packing done by 'packCommand'.
unpackCommand :: ByteString -> ByteString
unpackCommand = B.takeWhile (/= 0)

-- | Node offers no services.
nodeNone :: Word64
nodeNone = 0

-- | Services indicate node is a full node that can serve full blocks.
nodeNetwork :: Word64
nodeNetwork = 1

-- | Services indicate node allows to request 'UTXO' set.
nodeGetUTXO :: Word64
nodeGetUTXO = 1 `shiftL` 1

-- | Services indicate node accepts bloom filters.
nodeBloom :: Word64
nodeBloom = 1 `shiftL` 2

-- | Services indicate SegWit-capable node.
nodeWitness :: Word64
nodeWitness = 1 `shiftL` 3

-- | Services indicate Xtreme Thinblocks compatibility.
nodeXThin :: Word64
nodeXThin = 1 `shiftL` 4