content: {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE NoFieldSelectors #-}
  
  -- |
  -- 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 Data.ByteString qualified 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.
      list :: [NetworkAddressTime]
    }
    deriving (Eq, Show, Generic)
    deriving newtype (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.
      payload :: !VarString,
      -- | ECDSA signature of the payload
      signature :: !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
      list :: [InvVector]
    }
    deriving (Eq, Show, Generic)
    deriving newtype (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
      list :: [InvVector]
    }
    deriving (Eq, Show, Generic)
    deriving newtype (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)
    deriving newtype (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
      services :: !Word64,
      -- | address and port information
      address :: !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
      list :: [InvVector]
    }
    deriving (Eq, Show, Generic)
    deriving newtype (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.
      nonce :: Word64
    }
    deriving (Eq, Show, Read, Generic)
    deriving newtype (NFData)
  
  -- | A Pong message is sent as a response to a ping message.
  newtype Pong = Pong
    { -- | nonce from corresponding 'Ping'
      nonce :: Word64
    }
    deriving (Eq, Show, Read, Generic)
    deriving newtype (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
      message :: !MessageCommand,
      -- | rejection code
      code :: !RejectCode,
      -- | text reason for rejection
      reason :: !VarString,
      -- | extra data such as block or tx hash
      extra :: !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 {get :: Word64}
    deriving (Eq, Show, Read, Generic)
    deriving newtype (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 {get :: ByteString}
    deriving (Eq, Show, Read, Generic)
    deriving newtype (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
      nonce :: !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
  