content: -- | This module binds the C implementation of jets for Simplicity for assertions.
  {-# LANGUAGE ForeignFunctionInterface #-}
  module Simplicity.Elements.FFI.Env
   ( CTransaction, CTapEnv, CTxEnv
   , marshallTransaction, marshallTapEnv
   , withEnv, withPrimEnv
   ) where
  
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Lazy as BSL
  import Data.Foldable (toList)
  import Data.Serialize (Serialize, encode, runPut)
  import Data.Vector (Vector)
  import Data.Word (Word32)
  import Foreign.C.Types (CSize(..), CChar(..), CUChar(..), CUInt(..))
  import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
  import Foreign.Marshal.Alloc (allocaBytes)
  import Foreign.Marshal.Array (withArray, withArrayLen)
  import Foreign.Marshal.Unsafe (unsafeLocalState)
  import Foreign.Ptr (FunPtr, Ptr, nullPtr, plusPtr)
  import Foreign.Storable (Storable(..))
  import Lens.Family2 ((^.), under)
  
  import Simplicity.Digest
  import Simplicity.Elements.DataTypes
  import Simplicity.Elements.Primitive
  
  -- Abstract representative for the C txEnv types.
  newtype RawBuffer = RawBuffer RawBuffer
  newtype RawOutput = RawOutput RawOutput
  newtype RawInput = RawInput RawInput
  newtype RawTransaction = RawTransaction RawTransaction
  newtype RawTapEnv = RawTapEnv RawTapEnv
  newtype CTransaction = CTransaction CTransaction
  newtype CTapEnv = CTapEnv CTapEnv
  newtype CTxEnv = CTxEnv CTxEnv
  
  foreign import ccall unsafe "&" c_sizeof_rawElementsBuffer :: Ptr CSize
  foreign import ccall unsafe "&" c_sizeof_rawElementsOutput :: Ptr CSize
  foreign import ccall unsafe "&" c_sizeof_rawElementsInput :: Ptr CSize
  foreign import ccall unsafe "&" c_sizeof_rawElementsTransaction :: Ptr CSize
  foreign import ccall unsafe "&" c_sizeof_rawElementsTapEnv :: Ptr CSize
  foreign import ccall unsafe "&" c_sizeof_txEnv :: Ptr CSize
  
  foreign import ccall unsafe "" c_set_rawElementsBuffer :: Ptr RawBuffer -> Ptr CChar -> CUInt -> IO ()
  foreign import ccall unsafe "" c_set_rawElementsOutput :: Ptr RawOutput -> Ptr CChar -> Ptr CChar -> Ptr CChar -> Ptr RawBuffer -> Ptr RawBuffer -> Ptr RawBuffer -> IO ()
  foreign import ccall unsafe "" c_set_rawElementsInput :: Ptr RawInput -> Ptr RawBuffer -> Ptr CChar -> Ptr RawBuffer
                                                                -> Ptr CChar -> CUInt
                                                                -> Ptr CChar -> Ptr CChar -> Ptr RawBuffer
                                                                -> CUInt
                                                                -> Ptr CChar -> Ptr CChar -> Ptr CChar -> Ptr CChar
                                                                -> Ptr RawBuffer -> Ptr RawBuffer -> IO ()
  foreign import ccall unsafe "" c_set_rawElementsTransaction :: Ptr RawTransaction -> Ptr CChar -> CUInt
                                                                            -> Ptr RawInput -> CUInt
                                                                            -> Ptr RawOutput -> CUInt
                                                                            -> CUInt -> IO ()
  foreign import ccall unsafe "" c_set_rawElementsTapEnv :: Ptr RawTapEnv -> Ptr CChar -> CUChar -> Ptr CChar -> IO ()
  foreign import ccall unsafe "" c_set_txEnv :: Ptr CTxEnv -> Ptr CTransaction -> Ptr CTapEnv -> Ptr CChar -> CUInt -> IO ()
  
  foreign import ccall unsafe "" simplicity_elements_mallocTransaction :: Ptr RawTransaction -> IO (Ptr CTransaction)
  foreign import ccall unsafe "&" simplicity_elements_freeTransaction :: FunPtr (Ptr CTransaction -> IO ())
  foreign import ccall unsafe "" simplicity_elements_mallocTapEnv :: Ptr RawTapEnv -> IO (Ptr CTapEnv)
  foreign import ccall unsafe "&" simplicity_elements_freeTapEnv :: FunPtr (Ptr CTapEnv -> IO ())
  
  sizeof_rawBuffer :: Int
  sizeof_rawBuffer = fromIntegral . unsafeLocalState $ peek c_sizeof_rawElementsBuffer
  
  sizeof_rawOutput :: Int
  sizeof_rawOutput = fromIntegral . unsafeLocalState $ peek c_sizeof_rawElementsOutput
  
  sizeof_rawInput :: Int
  sizeof_rawInput = fromIntegral . unsafeLocalState $ peek c_sizeof_rawElementsInput
  
  sizeof_rawTransaction :: Int
  sizeof_rawTransaction = fromIntegral . unsafeLocalState $ peek c_sizeof_rawElementsTransaction
  
  sizeof_rawTapEnv :: Int
  sizeof_rawTapEnv = fromIntegral . unsafeLocalState $ peek c_sizeof_rawElementsTapEnv
  
  sizeof_txEnv :: Int
  sizeof_txEnv = fromIntegral . unsafeLocalState $ peek c_sizeof_txEnv
  
  withRawBuffer :: BSL.ByteString -> (Ptr RawBuffer -> IO b) -> IO b
  withRawBuffer str k =
    allocaBytes sizeof_rawBuffer $ \pRawBuffer ->
    BS.useAsCStringLen (BSL.toStrict str) $ \(pCharStr, len) -> do
      c_set_rawElementsBuffer pRawBuffer pCharStr (fromIntegral len)
      k pRawBuffer
  
  withIssuance :: Maybe Issuance -> (Ptr CChar -> Ptr CChar -> Ptr CChar -> Ptr CChar -> Ptr RawBuffer -> Ptr RawBuffer -> IO b) -> IO b
  withIssuance Nothing k =
    withArray (replicate 32 0) $ \pZero ->
    withRawBuffer mempty $ \pEmpty ->
    k pZero pZero nullPtr nullPtr pEmpty pEmpty
  withIssuance (Just (Left newIssue)) k =
    withArray (replicate 32 0) $ \pZero ->
    BS.useAsCString (encode (newIssuanceContractHash newIssue)) $ \pContract ->
    maybeAmount issueAmount $ \pAmount ->
    maybeAmount tokenAmount $ \pToken ->
    withRawBuffer (issueAmount ^. (under amount.prf_)) $ \pAmountRangeProof ->
    withRawBuffer (tokenAmount ^. (under amount.prf_)) $ \pTokenRangeProof ->
    k pZero pContract pAmount pToken pAmountRangeProof pTokenRangeProof
   where
    issueAmount = newIssuanceAmount newIssue
    tokenAmount = newIssuanceTokenAmount newIssue
    maybeAmount (Amount (Explicit 0)) k = k nullPtr
    maybeAmount amt k = BS.useAsCString (runPut . putAmount $ clearAmountPrf amt) k
  
  withIssuance (Just (Right reIssue)) k =
    BS.useAsCString (encode (reissuanceBlindingNonce reIssue)) $ \pBlinding ->
    BS.useAsCString (encode (reissuanceEntropy reIssue)) $ \pEntropy ->
    BS.useAsCString (runPut . putAmount $ clearAmountPrf issueAmount) $ \pAmount ->
    withRawBuffer (issueAmount ^. (under amount.prf_)) $ \pAmountRangeProof ->
    withRawBuffer mempty $ \pEmpty ->
    k pBlinding pEntropy pAmount nullPtr pAmountRangeProof pEmpty
   where
    issueAmount = reissuanceAmount reIssue
  
  withRawOutputs :: Vector TxOutput -> (Ptr RawOutput -> IO b) -> IO b
  withRawOutputs txos k =
    allocaBytes (len * sizeof_rawOutput) $ \pRawOutput ->
     foldr ($) (k pRawOutput) [pokeRawOutput txo (pRawOutput `plusPtr` (i*sizeof_rawOutput)) | (i, txo) <- zip [0..] (toList txos)]
   where
    len = fromIntegral $ length txos
    pokeRawOutput :: TxOutput -> Ptr RawOutput -> IO b -> IO b
    pokeRawOutput txo pRawOutput k =
      BS.useAsCString (runPut . putAsset . clearAssetPrf $ txoAsset txo) $ \pAsset ->
      BS.useAsCString (runPut . putAmount . clearAmountPrf $ txoAmount txo) $ \pAmount ->
      withMaybe (txoNonce txo) $ \pNonce ->
      withRawBuffer (txoScript txo) $ \pScript ->
      withRawBuffer (txoAsset txo ^. (under asset.prf_)) $ \pSurjectionProof ->
      withRawBuffer (txoAmount txo ^. (under amount.prf_)) $ \pRangeProof -> do
        c_set_rawElementsOutput pRawOutput pAsset pAmount pNonce pScript pSurjectionProof pRangeProof
        k
    withMaybe Nothing = ($ nullPtr)
    withMaybe (Just x) = BS.useAsCString (encode x)
  
  withRawInputs :: Vector SigTxInput -> (Ptr RawInput -> IO b) -> IO b
  withRawInputs txis k =
    allocaBytes (len * sizeof_rawInput) $ \pRawInput -> do
     foldr ($) (k pRawInput) [pokeRawInput txo (pRawInput `plusPtr` (i*sizeof_rawInput)) | (i, txo) <- zip [0..] (toList txis)]
   where
    len = fromIntegral $ length txis
    withMaybe Nothing = ($ nullPtr)
    withMaybe (Just x) = BS.useAsCString (encode x)
    withMaybeRawBuffer Nothing = ($ nullPtr)
    withMaybeRawBuffer (Just buf) = withRawBuffer buf
    pokeRawInput :: SigTxInput -> Ptr RawInput -> IO b -> IO b
    pokeRawInput txi pRawInput k =
      withMaybeRawBuffer (sigTxiAnnex txi) $ \pAnnex ->
      withMaybe (sigTxiPegin txi) $ \pPegin ->
      withRawBuffer (sigTxiScriptSig txi) $ \pScriptSig ->
      BS.useAsCString (encode . opHash $ sigTxiPreviousOutpoint txi) $ \pPrevTxid ->
      BS.useAsCString (runPut . putAsset . utxoAsset $ sigTxiTxo txi) $ \pAsset ->
      BS.useAsCString (runPut . putAmount . utxoAmount $ sigTxiTxo txi) $ \pValue ->
      withRawBuffer (utxoScript $ sigTxiTxo txi) $ \pScript ->
      withIssuance (sigTxiIssuance txi) $ \pBlindingNonce pAssetEntropy pAmount pInflationKeys pAmountRangeProof pInflationKeysRangeProof -> do
        c_set_rawElementsInput pRawInput pAnnex pPegin pScriptSig
                                 pPrevTxid (fromIntegral . opIndex . sigTxiPreviousOutpoint $ txi)
                                 pAsset pValue pScript
                                 (fromIntegral . sigTxiSequence $ txi)
                                 pBlindingNonce pAssetEntropy pAmount pInflationKeys
                                 pAmountRangeProof pInflationKeysRangeProof
        k
  
  withRawTransaction :: SigTx -> (Ptr RawTransaction -> IO b) -> IO b
  withRawTransaction tx k =
    allocaBytes sizeof_rawTransaction $ \pRawTransaction ->
    withRawInputs (sigTxIn tx) $ \pInput ->
    withRawOutputs (sigTxOut tx) $ \pOutput -> do
    BS.useAsCString (encode $ txid tx) $ \pTxid -> do
     c_set_rawElementsTransaction pRawTransaction pTxid version pInput numInputs pOutput numOutputs lockTime
     k pRawTransaction
   where
    version = fromIntegral (sigTxVersion tx)
    numInputs = fromIntegral $ length (sigTxIn tx)
    numOutputs = fromIntegral $ length (sigTxOut tx)
    lockTime = fromIntegral (sigTxLock tx)
  
  withRawTapEnv :: TapEnv -> (Ptr RawTapEnv -> IO b) -> IO b
  withRawTapEnv tapEnv k | length (tappath tapEnv) <= 128 =
    allocaBytes sizeof_rawTapEnv $ \pRawTapEnv ->
    BS.useAsCString encodePath $ \pControlBlock -> do
    BS.useAsCString (encode $ tapScriptCMR tapEnv) $ \pCmr -> do
     c_set_rawElementsTapEnv pRawTapEnv pControlBlock (fromIntegral . length $ tappath tapEnv) pCmr
     k pRawTapEnv
   where
    encodePath = BS.cons (tapleafVersion tapEnv) (BS.concat (encode (tapInternalKey tapEnv) : map encode (tappath tapEnv)))
  
  marshallTransaction :: SigTx -> IO (ForeignPtr CTransaction)
  marshallTransaction tx = withRawTransaction tx
                         $ \pRawTransaction -> simplicity_elements_mallocTransaction pRawTransaction >>= newForeignPtr simplicity_elements_freeTransaction
  
  marshallTapEnv :: TapEnv -> IO (ForeignPtr CTapEnv)
  marshallTapEnv env = withRawTapEnv env
                     $ \pRawTapEnv -> simplicity_elements_mallocTapEnv pRawTapEnv >>= newForeignPtr simplicity_elements_freeTapEnv
  
  withEnv :: ForeignPtr CTransaction -> Word32 -> ForeignPtr CTapEnv -> Hash256 -> (Ptr CTxEnv -> IO b) -> IO b
  withEnv cTransaction ix cTapEnv genesisHash k =
    allocaBytes sizeof_txEnv $ \pTxEnv ->
    withForeignPtr cTransaction $ \pTransaction ->
    withForeignPtr cTapEnv $ \pTapEnv ->
    BS.useAsCString (encode genesisHash) $ \pGenesis -> do
     c_set_txEnv pTxEnv pTransaction pTapEnv pGenesis (fromIntegral ix)
     k pTxEnv
  
  withPrimEnv :: PrimEnv -> (Ptr CTxEnv -> IO b) -> IO b
  withPrimEnv env k = do
    cTransaction <- marshallTransaction (envTx env)
    cTapEnv <- marshallTapEnv (envTap env)
    withEnv cTransaction (envIx env) cTapEnv (envGenesisBlock env) k
  