Update cardano-crypto-class to io-classes-1.4.1

cardano-crypto-class/cardano-crypto-class.cabal

@@ -101,7 +101,7 @@ library
     , cryptonite
     , deepseq
     , heapwords
-    , io-classes
+    , io-classes >= 1.4.1
     , memory
     , mtl
     , nothunks

cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs

@@ -36,7 +36,7 @@ import Control.DeepSeq (NFData (..), rwhnf)
 import Control.Monad ((<$!>), unless, guard)
 import Control.Monad.Class.MonadST (MonadST (..))
 import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO)
-import Control.Monad.ST (ST, stToIO)
+import Control.Monad.ST (ST)
 import Control.Monad.ST.Unsafe (unsafeIOToST)
 import qualified Data.ByteString as BS
 import Data.Proxy
@@ -109,13 +109,12 @@ cOrThrowError contextDesc cFunName action = do
 -- result code; if the result code returned is nonzero, fetch the errno, and
 -- return it.
 cOrError :: MonadST m => (forall s. ST s Int) -> m (Maybe Errno)
-cOrError action = do
-  withLiftST $ \fromST -> fromST $ do
-    res <- action
-    if res == 0 then
-      return Nothing
-    else
-      Just <$> unsafeIOToST getErrno
+cOrError action = stToIO $ do
+  res <- action
+  if res == 0 then
+    return Nothing
+  else
+    Just <$> unsafeIOToST getErrno
 
 -- | Throws an error when 'Just' an 'Errno' is given.
 throwOnErrno :: MonadThrow m => String -> String -> Maybe Errno -> m ()
@@ -259,7 +258,7 @@ instance DSIGNMAlgorithm Ed25519DSIGN where
         mlsbUseAsSizedPtr sk $ \skPtr -> do
           (psb, maybeErrno) <-
             psbCreateSizedResult $ \pkPtr ->
-              withLiftST $ \fromST -> fromST $ do
+              stToIO $ do
                 cOrError $ unsafeIOToST $
                   c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr
           throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno
@@ -271,8 +270,8 @@ instance DSIGNMAlgorithm Ed25519DSIGN where
       in SigEd25519DSIGN <$!> do
           mlsbUseAsSizedPtr sk $ \skPtr -> do
             (psb, maybeErrno) <-
-              psbCreateSizedResult $ \sigPtr -> do
-                withLiftST $ \fromST -> fromST $ do
+              psbCreateSizedResult $ \sigPtr ->
+                stToIO $ do
                   cOrError $ unsafeIOToST $ do
                     BS.useAsCStringLen bs $ \(ptr, len) ->
                       c_crypto_sign_ed25519_detached sigPtr nullPtr (castPtr ptr) (fromIntegral len) skPtr
@@ -287,8 +286,7 @@ instance DSIGNMAlgorithm Ed25519DSIGN where
       sk <- mlsbNewWith allocator
       mlsbUseAsSizedPtr sk $ \skPtr ->
         mlockedSeedUseAsCPtr seed $ \seedPtr -> do
-          maybeErrno <- withLiftST $ \fromST ->
-            fromST $ allocaSizedST $ \pkPtr -> do
+          maybeErrno <- stToIO $ allocaSizedST $ \pkPtr -> do
               cOrError $ unsafeIOToST $
                 c_crypto_sign_ed25519_seed_keypair pkPtr skPtr (SizedPtr . castPtr $ seedPtr)
           throwOnErrno "genKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" maybeErrno
@@ -304,10 +302,9 @@ instance DSIGNMAlgorithm Ed25519DSIGN where
       seed <- mlockedSeedNewWith allocator
       mlsbUseAsSizedPtr sk $ \skPtr ->
         mlockedSeedUseAsSizedPtr seed $ \seedPtr -> do
-          maybeErrno <- withLiftST $ \fromST ->
-            fromST $
-              cOrError $ unsafeIOToST $
-                c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr
+          maybeErrno <-
+            stToIO $ cOrError $ unsafeIOToST $
+              c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr
           throwOnErrno "genKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" maybeErrno
       return seed
 

cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs

@@ -49,13 +49,13 @@ expandHashWith
 expandHashWith allocator h (MLSB sfptr) = do
     withMLockedForeignPtr sfptr $ \ptr -> do
         l <- mlockedAllocaWith allocator size1 $ \ptr' -> do
-              withLiftST $ \liftST -> liftST . unsafeIOToST $ do
+              stToIO . unsafeIOToST $ do
                 poke ptr' (1 :: Word8)
                 copyMem (castPtr (plusPtr ptr' 1)) ptr size
                 naclDigestPtr h ptr' (fromIntegral size1)
 
         r <- mlockedAllocaWith allocator size1 $ \ptr' -> do
-              withLiftST $ \liftST -> liftST . unsafeIOToST $ do
+              stToIO . unsafeIOToST $ do
                 poke ptr' (2 :: Word8)
                 copyMem (castPtr (plusPtr ptr' 1)) ptr size
                 naclDigestPtr h ptr' (fromIntegral size1)

cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs

@@ -112,8 +112,8 @@ withMLSBChunk mlsb offset action
   = error $ "Overrun (" ++ show offset ++ " + " ++ show chunkSize ++ " > " ++ show parentSize ++ ")"
   | otherwise
   = withMLSB mlsb $ \ptr -> do
-      fptr <- withLiftST $ \lift -> do
-        lift $ unsafeIOToST (newForeignPtr_ . castPtr $ plusPtr ptr offset)
+      fptr <-
+        stToIO $ unsafeIOToST (newForeignPtr_ . castPtr $ plusPtr ptr offset)
       action (MLSB $! SFP $! fptr)
   where
     chunkSize = fromIntegral (natVal (Proxy @n'))
@@ -185,8 +185,7 @@ mlsbFromByteStringWith :: forall n m. (KnownNat n, MonadST m)
                        => MLockedAllocator m -> BS.ByteString -> m (MLockedSizedBytes n)
 mlsbFromByteStringWith allocator bs = do
   dst <- mlsbNewWith allocator
-  withMLSB dst $ \ptr -> do
-    withLiftST $ \liftST -> liftST . unsafeIOToST $ do
+  withMLSB dst $ \ptr -> stToIO . unsafeIOToST $ do
       BS.useAsCStringLen bs $ \(ptrBS, len) -> do
         copyMem (castPtr ptr) ptrBS (min (fromIntegral len) (mlsbSize dst))
   return dst
@@ -233,7 +232,7 @@ mlsbAsByteString mlsb@(MLSB (SFP fptr)) = BSI.PS (castForeignPtr fptr) 0 size
 mlsbToByteString :: forall n m. (KnownNat n, MonadST m) => MLockedSizedBytes n -> m BS.ByteString
 mlsbToByteString mlsb =
   withMLSB mlsb $ \ptr ->
-    withLiftST $ \liftST -> liftST . unsafeIOToST $ BS.packCStringLen (castPtr ptr, size)
+    stToIO . unsafeIOToST $ BS.packCStringLen (castPtr ptr, size)
   where
     size  :: Int
     size = fromIntegral (mlsbSize mlsb)
@@ -265,7 +264,7 @@ mlsbCompare :: forall n m. (MonadST m, KnownNat n) => MLockedSizedBytes n -> MLo
 mlsbCompare (MLSB x) (MLSB y) =
   withMLockedForeignPtr x $ \x' ->
     withMLockedForeignPtr y $ \y' -> do
-      res <- withLiftST $ \fromST -> fromST . unsafeIOToST $ c_sodium_compare x' y' size
+      res <- stToIO . unsafeIOToST $ c_sodium_compare x' y' size
       return $ compare res 0
   where
     size = fromInteger $ natVal (Proxy @n)

cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs

@@ -45,7 +45,7 @@ import Control.Exception (Exception, mask_)
 import Control.Monad (when, void)
 import Control.Monad.Class.MonadST
 import Control.Monad.Class.MonadThrow (MonadThrow (bracket))
-import Control.Monad.ST
+import Control.Monad.ST (RealWorld, ST)
 import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
@@ -84,8 +84,8 @@ withMLockedForeignPtr (SFP fptr) f = do
   r <$ unsafeIOToMonadST (touchForeignPtr fptr)
 
 finalizeMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> m ()
-finalizeMLockedForeignPtr (SFP fptr) = withLiftST $ \lift ->
-  (lift . unsafeIOToST) (finalizeForeignPtr fptr)
+finalizeMLockedForeignPtr (SFP fptr) =
+  unsafeIOToMonadST $ finalizeForeignPtr fptr
 
 {-# WARNING traceMLockedForeignPtr "Do not use traceMLockedForeignPtr in production" #-}
 
@@ -95,7 +95,7 @@ traceMLockedForeignPtr fptr = withMLockedForeignPtr fptr $ \ptr -> do
     traceShowM a
 
 unsafeIOToMonadST :: MonadST m => IO a -> m a
-unsafeIOToMonadST action = withLiftST ($ unsafeIOToST action)
+unsafeIOToMonadST = stToIO . unsafeIOToST
 
 makeMLockedPool :: forall n s. KnownNat n => ST s (Pool n s)
 makeMLockedPool = do
@@ -141,21 +141,21 @@ instance Exception AllocatorException
 
 mlockedMalloc :: MonadST m => MLockedAllocator m
 mlockedMalloc =
-  MLockedAllocator { mlAllocate = \ size -> withLiftST ($ unsafeIOToST (mlockedMallocIO size)) }
+  MLockedAllocator { mlAllocate = unsafeIOToMonadST . mlockedMallocIO }
 
 mlockedMallocIO :: CSize -> IO (MLockedForeignPtr a)
 mlockedMallocIO size = SFP <$> do
   if
     | size <= 32 -> do
-        coerce $ stToIO $ grabNextBlock mlockedPool32
+        fmap coerce $ stToIO $ grabNextBlock mlockedPool32
     | size <= 64 -> do
-        coerce $ stToIO $ grabNextBlock mlockedPool64
+        fmap coerce $ stToIO $ grabNextBlock mlockedPool64
     | size <= 128 -> do
-        coerce $ stToIO $ grabNextBlock mlockedPool128
+        fmap coerce $ stToIO $ grabNextBlock mlockedPool128
     | size <= 256 -> do
-        coerce $ stToIO $ grabNextBlock mlockedPool256
+        fmap coerce $ stToIO $ grabNextBlock mlockedPool256
     | size <= 512 -> do
-        coerce $ stToIO $ grabNextBlock mlockedPool512
+        fmap coerce $ stToIO $ grabNextBlock mlockedPool512
     | otherwise -> do
         mask_ $ do
           ptr <- sodiumMalloc size
@@ -193,8 +193,8 @@ allocaBytes size f =
   unsafeIOToST $ Foreign.allocaBytes size (unsafeSTToIO . f)
 
 packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString
-packByteStringCStringLen (ptr, len) =
-  withLiftST $ \lift -> lift . unsafeIOToST $ BS.packCStringLen (ptr, len)
+packByteStringCStringLen =
+  unsafeIOToMonadST . BS.packCStringLen
 
 newtype MLockedAllocator m =
   MLockedAllocator

cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs

@@ -280,9 +280,9 @@ psbUseAsSizedPtr ::
   PinnedSizedBytes n ->
   (SizedPtr n -> m r) ->
   m r
-psbUseAsSizedPtr (PSB ba) k = withLiftST $ \lift -> do
+psbUseAsSizedPtr (PSB ba) k = do
     r <- k (SizedPtr $ castPtr $ byteArrayContents ba)
-    r <$ lift (touch ba)
+    r <$ stToIO (touch ba)
 
 -- | As 'psbCreateResult', but presumes that no useful value is produced: that
 -- is, the function argument is run only for its side effects.
@@ -345,11 +345,11 @@ psbCreateResultLen ::
   (KnownNat n, MonadST m) =>
   (Ptr Word8 -> CSize -> m r) ->
   m (PinnedSizedBytes n, r)
-psbCreateResultLen f = withLiftST $ \lift -> do
+psbCreateResultLen f = do
   let len :: Int = fromIntegral . natVal $ Proxy @n
-  mba <- lift (newPinnedByteArray len)
+  mba <- stToIO (newPinnedByteArray len)
   res <- f (mutableByteArrayContents mba) (fromIntegral len)
-  arr <- lift (unsafeFreezeByteArray mba)
+  arr <- stToIO (unsafeFreezeByteArray mba)
   pure (PSB arr, res)
 
 -- | As 'psbCreateSizedResult', but presumes that no useful value is produced:
@@ -413,6 +413,6 @@ runAndTouch ::
   ByteArray ->
   (Ptr Word8 -> m a) ->
   m a
-runAndTouch ba f = withLiftST $ \lift -> do
+runAndTouch ba f = do
   r <- f (byteArrayContents ba)
-  r <$ lift (touch ba)
+  r <$ stToIO (touch ba)