{-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module      : Crypto.Secp256k1.Internal.Context
-- License     : UNLICENSE
-- Maintainer  : Jean-Pierre Rupp <jprupp@protonmail.ch>
-- Stability   : experimental
-- Portability : POSIX
--
-- The API for this module may change at any time. This is an internal module only
-- exposed for hacking and experimentation.
module Crypto.Secp256k1.Internal.Context where

import Control.Exception (bracket, mask_)
import Control.Monad (unless)
import Crypto.Secp256k1.Internal.ForeignTypes
  ( CtxFlags,
    LCtx,
    Ret,
    Seed32,
    isSuccess,
  )
import Crypto.Secp256k1.Internal.Util (withRandomSeed)
import Foreign (FunPtr, Ptr)
import Foreign.C (CInt (..), CString, CUInt (..))
import Foreign.ForeignPtr
  ( FinalizerPtr,
    ForeignPtr,
    finalizeForeignPtr,
    newForeignPtr,
    withForeignPtr,
  )
import GHC.Conc (writeTVar)
import System.IO.Unsafe (unsafePerformIO)

newtype Ctx = Ctx {Ctx -> ForeignPtr LCtx
get :: ForeignPtr LCtx}

randomizeContext :: Ctx -> IO ()
randomizeContext :: Ctx -> IO ()
randomizeContext (Ctx ForeignPtr LCtx
fctx) = ForeignPtr LCtx -> (Ptr LCtx -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr LCtx
fctx ((Ptr LCtx -> IO ()) -> IO ()) -> (Ptr LCtx -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr LCtx
ctx -> do
  Ret
ret <- (Ptr Seed32 -> IO Ret) -> IO Ret
forall a. (Ptr Seed32 -> IO a) -> IO a
withRandomSeed ((Ptr Seed32 -> IO Ret) -> IO Ret)
-> (Ptr Seed32 -> IO Ret) -> IO Ret
forall a b. (a -> b) -> a -> b
$ Ptr LCtx -> Ptr Seed32 -> IO Ret
contextRandomize Ptr LCtx
ctx
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Ret -> Bool
isSuccess Ret
ret) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Could not randomize context"

createContext :: IO Ctx
createContext :: IO Ctx
createContext = do
  Ctx
ctx <- IO Ctx -> IO Ctx
forall a. IO a -> IO a
mask_ (IO Ctx -> IO Ctx) -> IO Ctx -> IO Ctx
forall a b. (a -> b) -> a -> b
$ do
    Ptr LCtx
pctx <- CtxFlags -> IO (Ptr LCtx)
contextCreate CtxFlags
signVerify
    ForeignPtr LCtx -> Ctx
Ctx (ForeignPtr LCtx -> Ctx) -> IO (ForeignPtr LCtx) -> IO Ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinalizerPtr LCtx -> Ptr LCtx -> IO (ForeignPtr LCtx)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr LCtx
contextDestroyFunPtr Ptr LCtx
pctx
  Ctx -> IO ()
randomizeContext Ctx
ctx
  Ctx -> IO Ctx
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ctx
ctx

cloneContext :: Ctx -> IO Ctx
cloneContext :: Ctx -> IO Ctx
cloneContext (Ctx ForeignPtr LCtx
fctx) =
  ForeignPtr LCtx -> (Ptr LCtx -> IO Ctx) -> IO Ctx
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr LCtx
fctx ((Ptr LCtx -> IO Ctx) -> IO Ctx) -> (Ptr LCtx -> IO Ctx) -> IO Ctx
forall a b. (a -> b) -> a -> b
$ \Ptr LCtx
ctx -> IO Ctx -> IO Ctx
forall a. IO a -> IO a
mask_ (IO Ctx -> IO Ctx) -> IO Ctx -> IO Ctx
forall a b. (a -> b) -> a -> b
$ do
    Ptr LCtx
ctx' <- Ptr LCtx -> IO (Ptr LCtx)
contextClone Ptr LCtx
ctx
    ForeignPtr LCtx -> Ctx
Ctx (ForeignPtr LCtx -> Ctx) -> IO (ForeignPtr LCtx) -> IO Ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinalizerPtr LCtx -> Ptr LCtx -> IO (ForeignPtr LCtx)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr LCtx
contextDestroyFunPtr Ptr LCtx
ctx'

destroyContext :: Ctx -> IO ()
destroyContext :: Ctx -> IO ()
destroyContext (Ctx ForeignPtr LCtx
fctx)= ForeignPtr LCtx -> IO ()
forall a. ForeignPtr a -> IO ()
finalizeForeignPtr ForeignPtr LCtx
fctx

withContext :: (Ctx -> IO a) -> IO a
withContext :: forall a. (Ctx -> IO a) -> IO a
withContext = (IO Ctx
createContext IO Ctx -> (Ctx -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)

verify :: CtxFlags
verify :: CtxFlags
verify = CtxFlags
0x0101

sign :: CtxFlags
sign :: CtxFlags
sign = CtxFlags
0x0201

signVerify :: CtxFlags
signVerify :: CtxFlags
signVerify = CtxFlags
0x0301

foreign import ccall safe "secp256k1.h secp256k1_context_create"
  contextCreate ::
    CtxFlags ->
    IO (Ptr LCtx)

foreign import ccall safe "secp256k1.h secp256k1_context_clone"
  contextClone ::
    Ptr LCtx ->
    IO (Ptr LCtx)

foreign import ccall safe "secp256k1.h secp256k1_context_destroy"
  contextDestroy :: Ptr LCtx -> IO ()

foreign import ccall safe "secp256k1.h &secp256k1_context_destroy"
  contextDestroyFunPtr :: FunPtr (Ptr LCtx -> IO ())

foreign import ccall safe "secp256k1.h secp256k1_context_set_illegal_callback"
  setIllegalCallback ::
    Ptr LCtx ->
    -- | message, data
    FunPtr (CString -> Ptr a -> IO ()) ->
    -- | data
    Ptr a ->
    IO ()

foreign import ccall safe "secp256k1.h secp256k1_context_set_error_callback"
  setErrorCallback ::
    Ptr LCtx ->
    -- | message, data
    FunPtr (CString -> Ptr a -> IO ()) ->
    -- | data
    Ptr a ->
    IO ()

foreign import ccall safe "secp256k1.h secp256k1_context_randomize"
  contextRandomize ::
    Ptr LCtx ->
    Ptr Seed32 ->
    IO Ret