{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Crypto.AllocLog where

import Control.Tracer
import Foreign.Concurrent
import Foreign.Ptr

import Cardano.Crypto.Libsodium (withMLockedForeignPtr)
import Cardano.Crypto.Libsodium.Memory (MLockedAllocator (..))
import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..))

-- | Allocation log event. These are emitted automatically whenever mlocked
-- memory is allocated through the 'mlockedAllocForeignPtr' primitive, or
-- released through an associated finalizer (either explicitly or due to GC).
-- Additional events that are not actual allocations/deallocations, but may
-- provide useful debugging context, can be inserted as 'MarkerEv'.
data AllocEvent
  = AllocEv !WordPtr
  | FreeEv !WordPtr
  | MarkerEv !String
  deriving (AllocEvent -> AllocEvent -> Bool
(AllocEvent -> AllocEvent -> Bool)
-> (AllocEvent -> AllocEvent -> Bool) -> Eq AllocEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AllocEvent -> AllocEvent -> Bool
== :: AllocEvent -> AllocEvent -> Bool
$c/= :: AllocEvent -> AllocEvent -> Bool
/= :: AllocEvent -> AllocEvent -> Bool
Eq, Int -> AllocEvent -> ShowS
[AllocEvent] -> ShowS
AllocEvent -> String
(Int -> AllocEvent -> ShowS)
-> (AllocEvent -> String)
-> ([AllocEvent] -> ShowS)
-> Show AllocEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AllocEvent -> ShowS
showsPrec :: Int -> AllocEvent -> ShowS
$cshow :: AllocEvent -> String
show :: AllocEvent -> String
$cshowList :: [AllocEvent] -> ShowS
showList :: [AllocEvent] -> ShowS
Show)

mkLoggingAllocator ::
  Tracer IO AllocEvent -> MLockedAllocator IO -> MLockedAllocator IO
mkLoggingAllocator :: Tracer IO AllocEvent -> MLockedAllocator IO -> MLockedAllocator IO
mkLoggingAllocator Tracer IO AllocEvent
tracer MLockedAllocator IO
ioAllocator =
  MLockedAllocator
    { mlAllocate :: forall a. CSize -> IO (MLockedForeignPtr a)
mlAllocate =
        \CSize
size -> do
          sfptr :: MLockedForeignPtr a
sfptr@(SFP ForeignPtr a
fptr) <- MLockedAllocator IO -> forall a. CSize -> IO (MLockedForeignPtr a)
forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate MLockedAllocator IO
ioAllocator CSize
size
          WordPtr
addr <- MLockedForeignPtr a -> (Ptr a -> IO WordPtr) -> IO WordPtr
forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr MLockedForeignPtr a
sfptr (WordPtr -> IO WordPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WordPtr -> IO WordPtr)
-> (Ptr a -> WordPtr) -> Ptr a -> IO WordPtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr)
          Tracer IO AllocEvent -> AllocEvent -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO AllocEvent
tracer (WordPtr -> AllocEvent
AllocEv WordPtr
addr)
          ForeignPtr a -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
addForeignPtrFinalizer ForeignPtr a
fptr (Tracer IO AllocEvent -> AllocEvent -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO AllocEvent
tracer (WordPtr -> AllocEvent
FreeEv WordPtr
addr))
          MLockedForeignPtr a -> IO (MLockedForeignPtr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MLockedForeignPtr a
sfptr
    }