diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# Version 1.0.18.1 + +* Improve support for opaque C structs (`Storable`, `Ptr`, allocation). + + # Version 1.0.18.0 * Initial version. diff --git a/lib/Libsodium.chs b/lib/Libsodium.chs --- a/lib/Libsodium.chs +++ b/lib/Libsodium.chs @@ -1,10 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} #include @@ -334,19 +337,39 @@ -- -- $types , Crypto_aead_aes256gcm_state + , crypto_aead_aes256gcm_state'ptr + , crypto_aead_aes256gcm_state'malloc , Crypto_auth_hmacsha256_state + , crypto_auth_hmacsha256_state'ptr + , crypto_auth_hmacsha256_state'malloc + , Crypto_auth_hmacsha512256_state , Crypto_auth_hmacsha512_state + , crypto_auth_hmacsha512_state'ptr + , crypto_auth_hmacsha512_state'malloc , Crypto_generichash_blake2b_state + , crypto_generichash_blake2b_state'ptr + , crypto_generichash_blake2b_state'malloc + , Crypto_generichash_state , Crypto_hash_sha256_state + , crypto_hash_sha256_state'ptr + , crypto_hash_sha256_state'malloc , Crypto_hash_sha512_state + , crypto_hash_sha512_state'ptr + , crypto_hash_sha512_state'malloc , Crypto_onetimeauth_poly1305_state + , crypto_onetimeauth_poly1305_state'ptr + , crypto_onetimeauth_poly1305_state'malloc + , Crypto_onetimeauth_state , Crypto_secretstream_xchacha20poly1305_state + , crypto_secretstream_xchacha20poly1305_state'ptr + , crypto_secretstream_xchacha20poly1305_state'malloc , Crypto_sign_ed25519ph_state - , Crypto_auth_hmacsha512256_state - , Crypto_generichash_state - , Crypto_onetimeauth_state + , crypto_sign_ed25519ph_state'ptr + , crypto_sign_ed25519ph_state'malloc , Crypto_sign_state , Randombytes_implementation + , randombytes_implementation'ptr + , randombytes_implementation'malloc -- * Constants -- -- $constants @@ -354,9 +377,12 @@ ) --} where +import Data.Coerce import Data.Proxy import Data.Word import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Array (copyArray) import Foreign.Ptr import Foreign.Storable import GHC.TypeLits @@ -782,15 +808,33 @@ -------------------------------------------------------------------------------- -- $types -- --- These are types used by some of the functions in --- "Libsodium". They are exported as opaque types. +-- These are types used by some of the functions in "Libsodium". +-- They are exported as opaque types having a particular size and +-- alignment described by their 'Storable' instance. -- --- Use 'Storable' if you need to allocate values of these types. - -newtype Crypto_aead_aes256gcm_state = Crypto_aead_aes256gcm_state - (Opaque 16 {# sizeof crypto_aead_aes256gcm_state #}) +-- Use the @/xxx/'malloc@ functions to allocate values of type @Xxx@. These +-- will be freed from memory as soon as they become unused. +-- +-- Use the @/xxx/'ptr@ function to obtain a +-- @'Ptr' Xxx@ suitable for passing to functions. +newtype Crypto_aead_aes256gcm_state + = Crypto_aead_aes256gcm_state + (Opaque 16 {# sizeof crypto_aead_aes256gcm_state #}) deriving newtype (Storable) +crypto_aead_aes256gcm_state'malloc + :: IO Crypto_aead_aes256gcm_state +crypto_aead_aes256gcm_state'malloc = + fmap Crypto_aead_aes256gcm_state opaque'malloc + +crypto_aead_aes256gcm_state'ptr + :: Crypto_aead_aes256gcm_state + -> (Ptr Crypto_aead_aes256gcm_state -> IO x) + -> IO x +crypto_aead_aes256gcm_state'ptr = opaque'ptr + @Crypto_aead_aes256gcm_state + +--- type Crypto_sign_state = Crypto_sign_ed25519ph_state newtype Crypto_sign_ed25519ph_state = Crypto_sign_ed25519ph_state @@ -798,34 +842,58 @@ {# sizeof crypto_sign_ed25519ph_state #}) deriving newtype (Storable) +crypto_sign_ed25519ph_state'ptr = opaque'ptr @Crypto_sign_ed25519ph_state +crypto_sign_ed25519ph_state'malloc = fmap Crypto_sign_ed25519ph_state opaque'malloc + +--- newtype Crypto_secretstream_xchacha20poly1305_state = Crypto_secretstream_xchacha20poly1305_state (Opaque {# alignof crypto_secretstream_xchacha20poly1305_state #} {# sizeof crypto_secretstream_xchacha20poly1305_state #}) deriving newtype (Storable) +crypto_secretstream_xchacha20poly1305_state'ptr = opaque'ptr @Crypto_secretstream_xchacha20poly1305_state +crypto_secretstream_xchacha20poly1305_state'malloc = fmap Crypto_secretstream_xchacha20poly1305_state opaque'malloc + +--- type Crypto_onetimeauth_state = Crypto_onetimeauth_poly1305_state newtype Crypto_onetimeauth_poly1305_state = Crypto_onetimeauth_poly1305_state (Opaque 16 {# sizeof crypto_onetimeauth_poly1305_state #}) deriving newtype (Storable) +crypto_onetimeauth_poly1305_state'ptr = opaque'ptr @Crypto_onetimeauth_poly1305_state +crypto_onetimeauth_poly1305_state'malloc = fmap Crypto_onetimeauth_poly1305_state opaque'malloc + +--- type Crypto_generichash_state = Crypto_generichash_blake2b_state newtype Crypto_generichash_blake2b_state = Crypto_generichash_blake2b_state (Opaque 64 {# sizeof crypto_generichash_blake2b_state #}) deriving newtype (Storable) +crypto_generichash_blake2b_state'ptr = opaque'ptr @Crypto_generichash_blake2b_state +crypto_generichash_blake2b_state'malloc = fmap Crypto_generichash_blake2b_state opaque'malloc + +--- newtype Crypto_hash_sha256_state = Crypto_hash_sha256_state (Opaque {# alignof crypto_hash_sha256_state #} {# sizeof crypto_hash_sha256_state #}) deriving newtype (Storable) +crypto_hash_sha256_state'ptr = opaque'ptr @Crypto_hash_sha256_state +crypto_hash_sha256_state'malloc = fmap Crypto_hash_sha256_state opaque'malloc + +--- newtype Crypto_hash_sha512_state = Crypto_hash_sha512_state (Opaque {# alignof crypto_hash_sha512_state #} {# sizeof crypto_hash_sha512_state #}) deriving newtype (Storable) +crypto_hash_sha512_state'ptr = opaque'ptr @Crypto_hash_sha512_state +crypto_hash_sha512_state'malloc = fmap Crypto_hash_sha512_state opaque'malloc + +--- type Crypto_auth_hmacsha512256_state = Crypto_auth_hmacsha512_state newtype Crypto_auth_hmacsha512_state = Crypto_auth_hmacsha512_state @@ -833,25 +901,54 @@ {# sizeof crypto_auth_hmacsha512_state #}) deriving newtype (Storable) +crypto_auth_hmacsha512_state'ptr = opaque'ptr @Crypto_auth_hmacsha512_state +crypto_auth_hmacsha512_state'malloc = fmap Crypto_auth_hmacsha512_state opaque'malloc + +--- newtype Crypto_auth_hmacsha256_state = Crypto_auth_hmacsha256_state (Opaque {# alignof crypto_auth_hmacsha256_state #} {# sizeof crypto_auth_hmacsha256_state #}) deriving newtype (Storable) +crypto_auth_hmacsha256_state'ptr = opaque'ptr @Crypto_auth_hmacsha256_state +crypto_auth_hmacsha256_state'malloc = fmap Crypto_auth_hmacsha256_state opaque'malloc + +--- newtype Randombytes_implementation = Randombytes_implementation (Opaque {# alignof randombytes_implementation #} {# sizeof randombytes_implementation #}) deriving newtype (Storable) +randombytes_implementation'ptr = opaque'ptr @Randombytes_implementation +randombytes_implementation'malloc = fmap Randombytes_implementation opaque'malloc + -------------------------------------------------------------------------------- -newtype Opaque (alignment :: Nat) (size :: Nat) = Opaque (Ptr ()) +newtype Opaque (alignment :: Nat) (size :: Nat) + = Opaque (ForeignPtr (Opaque alignment size)) instance forall a s. (KnownNat a, KnownNat s) => Storable (Opaque a s) where alignment _ = fromIntegral (natVal (Proxy :: Proxy a)) sizeOf _ = fromIntegral (natVal (Proxy :: Proxy s)) - peek z = Opaque <$> peek (castPtr z) - poke z (Opaque a) = poke (castPtr z) a + peek ps = do + fpd <- mallocForeignPtr + withForeignPtr fpd $ \pd -> copyArray pd ps 1 + pure $ Opaque fpd + poke pd (Opaque fps) = + withForeignPtr fps $ \ps -> copyArray pd ps 1 + +opaque'malloc :: (KnownNat a, KnownNat s) => IO (Opaque a s) +opaque'malloc = fmap Opaque mallocForeignPtr + +opaque'ptr + :: forall o a s x + . Coercible o (Opaque a s) + => o + -> (Ptr o -> IO x) + -> IO x +opaque'ptr o g = + let Opaque fp = coerce o :: Opaque a s + in withForeignPtr fp (g . castPtr) -------------------------------------------------------------------------------- -- $constants diff --git a/libsodium.cabal b/libsodium.cabal --- a/libsodium.cabal +++ b/libsodium.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: libsodium -version: 1.0.18.0 +version: 1.0.18.1 license: ISC license-file: LICENSE extra-source-files: README.md CHANGELOG.md diff --git a/test/Main.chs b/test/Main.chs --- a/test/Main.chs +++ b/test/Main.chs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} #include module Main (main) where @@ -6,6 +8,8 @@ import Control.Monad.IO.Class import Foreign.C.String import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Storable import qualified Test.Tasty as Tasty import qualified Test.Tasty.Runners as Tasty import Test.Tasty (TestTree, testGroup) @@ -68,6 +72,39 @@ [ tt_core , tt_constants , tt_randombytes + , tt_storable + ] + +tt_storable :: TestTree +tt_storable = testGroup "Storable" + [ testCase "alloc" $ do + _ :: ForeignPtr L.Crypto_hash_sha256_state <- mallocForeignPtr + pure () + + , testCase "peek" $ do + -- Allocate s1 and fill with random bytes + s1 <- L.crypto_hash_sha256_state'malloc + L.crypto_hash_sha256_state'ptr s1 $ \p1 -> do + L.randombytes_buf p1 (fromIntegral (sizeOf s1)) + -- Allocate s2 by peeking from s1 + s2 <- peek p1 + L.crypto_hash_sha256_state'ptr s2 $ \p2 -> do + -- Compare s1 and s2 + x <- L.sodium_memcmp p1 p2 (fromIntegral (sizeOf s1)) + 0 @=? x + + , testCase "poke" $ do + -- Allocate s1 and fill with random bytes + s1 <- L.crypto_hash_sha256_state'malloc + L.crypto_hash_sha256_state'ptr s1 $ \p1 -> do + L.randombytes_buf p1 (fromIntegral (sizeOf s1)) + -- Allocate s2 and poke s1 into it + s2 <- L.crypto_hash_sha256_state'malloc + L.crypto_hash_sha256_state'ptr s2 $ \p2 -> do + poke p2 s1 + -- Compare s1 and s2 + x <- L.sodium_memcmp p1 p2 (fromIntegral (sizeOf s1)) + 0 @=? x ] tt_core :: TestTree