Update continued: Replacing mkBindings with BotanObject

Picking up where we left off yesterday, its time for some code! We’re going to replace the mkBindings function with something more compact.

Minor aside - upgrading Memorable

Per yesterday’s discussion, mkBindings takes 2 newtype constructors-getter pairs (one wraps a Ptr, the other a ForeignPtr), and a FinalizerPtr for the destructor. All of the botan context objects follow this pattern, so we’re going to just codify this as a typeclass, making it a lot easier to wrangle.

Preparing today’s update involved making a few small changes to the Memorable class:

class ... => Memorable memo where
    -- Added
    type MemRep memo :: Type
    -- Changed
    withMem :: memo -> (Mem memo (MemRep memo) -> IO a) -> IO a

We have added a new MemRep associated type family, for the underlying memory type - so for ByteString, which is a Ptr Word8, Mem is Ptr, and MemRep is Word8, respectively. This allows us to not care whether a Memory type is monomorphic (eg, ByteString) or polymorphic (eg ForeignPtr). I had suspected that this would be necessary sooner or later, per earlier notes on the wildcard a parameter in withMem, which has now become fixed to MemRep memo.

NOTE: This change in general does have implications that I am still pondering, such as no longer being 1:1 drop-in compatible with memory:ByteArrayAccess.withByteArray, but I’d rather allow non-castable memory types and require that you usecastPtr, than the inverse, and it seems so much more sensible that if we allocate a ByteString with a length corresponding to a number of bytes, then when we access the pointer of that bytestring it should be aPtr Word8, and we should have to cast when we want anything else. It is more type-safe, and the longer I think about it, the more confused I am as to why memory did it that way.

Back to refactoring Botan.Low.RNG

Now, we’re going to start with a bit of a fresh slate - no Internal.ByteString or Make or Remake, just the bindings and our new supporting Memory classes:

-- Used to define BotanObject
{-# LANGUAGE AllowAmbiguousTypes #-}

import Botan.Bindings.ConstPtr (ConstPtr (..))
import Botan.Bindings.RNG

import Control.Monad (void)
import Control.Exception (mask_)

import Data.Kind
import Data.ByteString (ByteString)

import Foreign.Ptr (Ptr)
import qualified Foreign.Ptr as Ptr
import qualified Foreign.Storable as Ptr

import Foreign.ForeignPtr (ForeignPtr, FinalizerPtr)
import qualified Foreign.ForeignPtr as ForeignPtr

import Foreign.C.Types (CInt)
import Foreign.Marshal.Alloc (alloca)

-- This vvv is really the only 'new' import
-- I could actually pull in even more but this suffices

import Memory.Memory
import Memory.Pointer

There are a few things to note immediately - because RNG and BotanRNG are just a ForeignPtr and a Ptr respectively, they actually conform to Memorable.

BotanRNG gets an orphan instance since it is declared in Botan.Bindings.RNG.

instance Memorable BotanRNG where
    type Mem BotanRNG = Ptr
    type MemRep BotanRNG = BotanRNGStruct
    withMem (MkBotanRNG ptr) action = action ptr

Our definition of RNG hasn’t changed, and it gets a Memorable instance too.

newtype RNG = MkRNG { foreignPtr :: ForeignPtr BotanRNGStruct }

instance Memorable RNG where
    type Mem RNG = ForeignPtr
    type MemRep RNG = BotanRNGStruct
    withMem (MkRNG fptr) action = action fptr

Now comes the bit of the code where before we would use mkBindings to generate these functions:

withRNG     :: RNG -> (BotanRNG -> IO a) -> IO a
rngDestroy  :: RNG -> IO ()
createRNG   :: (Ptr BotanRNG -> IO CInt) -> IO RNG

Since all these do is pack and unpack pointers and finalizers, we are going to codify it as a typeclass instead of an awkward function that returns functions - that means we need to take a look at mkBindings itself, to see how it works:

mkBindings
    ::  (Storable botan)
    =>  (Ptr struct -> botan)                                   -- mkBotan
    ->  (botan -> Ptr struct)                                   -- runBotan
    ->  (ForeignPtr struct -> object)                           -- mkForeign
    ->  (object -> ForeignPtr struct)                           -- runForeign
    ->  FinalizerPtr struct                                     -- destroy / finalizer
    ->  (   object -> (botan -> IO a) -> IO a                   -- withObject
        ,   object -> IO ()                                     -- destroyObject
        ,   (Ptr botan -> IO CInt) -> IO object                 -- createObject
        )
mkBindings mkBotan runBotan mkForeign runForeign destroy = bindings where
    bindings = (withObject, objectDestroy, createObject)
    newObject botan = do
        foreignPtr <- newForeignPtr destroy (runBotan botan)
        return $ mkForeign foreignPtr
    withObject object f = withForeignPtr (runForeign object) (f . mkBotan)
    objectDestroy object = finalizeForeignPtr (runForeign object)
    createObject = mkCreateObject newObject

mkCreateObject
    :: (Storable botan)
    => (botan -> IO object)
    -> (Ptr botan-> IO CInt)
    -> IO object
mkCreateObject newObject init = mask_ $ alloca $ \ outPtr -> do
        throwBotanIfNegative_ $ init outPtr
        out <- peek outPtr
        newObject out

I think it is about the most confusing code I have ever written. That’s because botan requires that we allocate a pointer to a pointer to an opaque struct*, that it fills, that we have to peek at, attach a finalizer to, and wrap it up, all while handling a potential allocation or initialization failure. Luckily we were fairly smart - we use mask_ and alloca for the ptr-ptr, it is really just confusing as to when things are what, and that type definition is some horror upon the deep.

• Technically, a pointer to the CApiFFI-enforced newtype-wrapper over a pointer to an opaque struct, that we must first unwrap before rewrapping…

So lets clean that up with a little more of our recently-favorite hammer, TypeFamilies, shall we?

NOTE: Data families would also work, if we redefined Bindings and Low as a single module, and if CApiFFI / CTYPE allowed it (no idea if it does)

class
    ( Memorable a
    , Memorable (BotanPtr a)
    , Mem a            ~ ForeignPtr
    , Mem (BotanPtr a) ~ Ptr
    , MemRep a            ~ BotanStruct a
    , MemRep (BotanPtr a) ~ BotanStruct a
    ) => BotanObject a where

    type family BotanStruct a :: Type
    type family BotanPtr    a :: Type

    toBotanPtr :: Ptr (BotanStruct a) -> BotanPtr a
    toBotan    :: ForeignPtr (BotanStruct a) -> a
    botanFinalizer :: FinalizerPtr (BotanStruct a)

    withBotanPtr :: a -> (BotanPtr a -> IO b) -> IO b
    createBotan :: (Ptr (BotanPtr a) -> IO CInt) -> IO a
    destroyBotan :: a -> IO ()

Lets take a moment to clarify the way this works: BotanStruct Foo now refers to BotanFooStruct, and BotanPtr Foo is now a Memorable, who’s mem is a Ptr and who’s rep is a BotanFooStruct. We just codified a relationship between the wrapper types such that the Foo type (which is a Memorable ForeignPtr BotanFooStruct) ties them all together., that’s all. It feels odd to declare a type family and then immediately force-constrain it, but remember, we’re actually constraining the corresponding Mem and MemRep types to be relevant to each other.

Then, once you deal with your types, we can fill in the functions with reasonable defaults:

-- class BotanObject a continued

    withBotanPtr :: a -> (BotanPtr a -> IO b) -> IO b
    withBotanPtr botan action =
        withMem botan $ \ fptr -> do
            withMem fptr $ \ ptr -> do
                action (toBotanPtr @a ptr)

    createBotan :: (Ptr (BotanPtr a) -> IO CInt) -> IO a
    createBotan init = mask_ $ alloca $ \ ptrPtr -> do
        throwBotanIfNegative_ $ init (Ptr.castPtr ptrPtr) -- NOTE: Can be defined without this cast
        ptr <- Ptr.peek ptrPtr
        fptr <- ForeignPtr.newForeignPtr (botanFinalizer @a) ptr
        return $ toBotan fptr

    destroyBotan :: a -> IO ()
    destroyBotan botan = withMem botan ForeignPtr.finalizeForeignPtr

The noted cast turns a Ptr (Ptr BotanFooStruct) into a Ptr (BotanPtr Foo) for the init method, which we could avoid by applying a Ptr.Storable (BotanPtr a) constraint to the BotanObject a instead - we just cast it knowing that it is a newtype over the pointer we want. Then we just get the pointer out from the temporary ptr-ptr, stick it in a ForeignPtr with our finalizer, before finally returning the wrapped foreign pointer.

NOTE: Ideally I’d be doing something like withMem ptrPtr $ \ ptr -> throwBotanIfNegative_ $ init (toBotanPtr @a ptr) but (as part of the aforementioned repercussions of de-wilding withMem) the withMem implementation for Ptr is currently simply id meaning we can’t use it on a ptr-ptr like we expected - to fix that we would need to relax Memorable (Ptr a) to Memorable (Ptr (Ptr a)) which I might in the near future.

So, how well does this work? Let’s define our instance for RNG - it should be reasonably similar to how difficult it will be for other Botan objects, so this will give idea of how hard this will be to apply to the rest of the library:

instance BotanObject RNG where

    type BotanStruct RNG = BotanRNGStruct
    type BotanPtr    RNG = BotanRNG

    toBotanPtr ptr  = MkBotanRNG ptr
    toBotan    fptr = MkRNG      fptr
    botanFinalizer  = botan_rng_destroy

And that’s it! RNG no longer needs mkBindings, this does all of the same work.

Next up, we’ll be dealing with the helper methods, such as mkCreateObjectCString in:

rngInit :: RNGType -> IO RNG
rngInit = mkCreateObjectCString createBotan botan_rng_init

Nominally, there is nothing wrong with this, aside from mkCreateObjectCString being a part of mkBindings, and thus, is no longer imported. However, it is just a thin wrapper around createBotan that calls withMem over a bytestring before passing it as an additional argument - very reader / profunctor-ish, possibly unnecessary or kept after refactoring to also use the Memory classes.

We will get to that next time, as we continue finishing our refactor of the RNG module.