Add crypto backend using various reference librariesHEADmaster

9 files changed, 425 insertions, 0 deletions

diff --git a/src/crypto/reflibs/Crypto.hs b/src/crypto/reflibs/Crypto.hs
new file mode 100644
index 0000000..0b98b82
--- /dev/null
+++ b/src/crypto/reflibs/Crypto.hs
@@ -0,0 +1,23 @@
+module Crypto (
+    module Crypto.Random.Entropy,
+    module Crypto.Random,
+
+    module Crypto.Hash,
+
+    module Crypto.Cipher.ChaChaPoly1305,
+
+    module Crypto.PubKey.Ed25519,
+    module Crypto.PubKey.Curve25519,
+
+    CryptoFailable(..),
+    maybeCryptoError,
+    throwCryptoErrorIO,
+) where
+
+import Crypto.Cipher.ChaChaPoly1305
+import Crypto.Error
+import Crypto.Hash
+import Crypto.PubKey.Curve25519
+import Crypto.PubKey.Ed25519
+import Crypto.Random
+import Crypto.Random.Entropy
diff --git a/src/crypto/reflibs/Crypto/Cipher/ChaChaPoly1305.hs b/src/crypto/reflibs/Crypto/Cipher/ChaChaPoly1305.hs
new file mode 100644
index 0000000..c849c0b
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/Cipher/ChaChaPoly1305.hs
@@ -0,0 +1,72 @@
+module Crypto.Cipher.ChaChaPoly1305 (
+    AeadState, Nonce, Auth(..),
+    authTag,
+    nonce8, nonce12,
+    aeadInitialize,
+    aeadAppendAAD, aeadFinalizeAAD,
+    encrypt, decrypt,
+    aeadFinalize,
+) where
+
+import Crypto.AEAD.ChaCha20Poly1305 qualified as P
+import Crypto.Error
+import Crypto.MAC.Poly1305
+
+import Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+
+
+data AeadState = AeadState
+    { stKey :: ByteString
+    , stNonce :: Nonce
+    , stAAD :: [ ByteString ]
+    , stAuth :: Maybe Auth
+    }
+
+newtype Nonce = Nonce ByteString
+    deriving (Eq, ByteArrayAccess)
+
+nonce8 :: Bytes -> Bytes -> CryptoFailable Nonce
+nonce8 c iv
+    | BA.length c /= 4 = CryptoFailed CryptoError
+    | BA.length iv /= 8 = CryptoFailed CryptoError
+    | otherwise = CryptoPassed $ Nonce $ B.concat $ [ BA.convert c, BA.convert iv ]
+
+nonce12 :: Bytes -> CryptoFailable Nonce
+nonce12 iv
+    | BA.length iv /= 12 = CryptoFailed CryptoError
+    | otherwise = CryptoPassed $ Nonce $ BA.convert iv
+
+aeadInitialize :: ScrubbedBytes -> Nonce -> CryptoFailable AeadState
+aeadInitialize key nonce
+    | BA.length key /= 32 = CryptoFailed CryptoError
+    | otherwise = CryptoPassed AeadState
+        { stKey = BA.convert key
+        , stNonce = nonce
+        , stAAD = []
+        , stAuth = Nothing
+        }
+
+aeadAppendAAD :: ByteString -> AeadState -> AeadState
+aeadAppendAAD aad st = st { stAAD = stAAD st ++ [ aad ] }
+
+aeadFinalizeAAD :: AeadState -> AeadState
+aeadFinalizeAAD = id
+
+encrypt :: ByteArray ba => ba -> AeadState -> ( ba, AeadState )
+encrypt ptext st =
+    let Nonce nonce = stNonce st
+        ( ctext, mac ) = P.encrypt (B.concat $ stAAD st) (stKey st) nonce (convert ptext)
+     in ( convert ctext, st { stAuth = Just $ Auth mac } )
+
+decrypt :: ByteArray ba => ( ba, Auth ) -> AeadState -> Maybe ba
+decrypt ( ctext, auth ) st = do
+    let Nonce nonce = stNonce st
+        Auth mac = auth
+    fmap convert $ P.decrypt (B.concat $ stAAD st) (stKey st) nonce ( convert ctext, mac )
+
+aeadFinalize :: AeadState -> Auth
+aeadFinalize st = case stAuth st of
+    Just auth -> auth
+    Nothing -> aeadFinalize $ snd $ encrypt B.empty st
diff --git a/src/crypto/reflibs/Crypto/Error.hs b/src/crypto/reflibs/Crypto/Error.hs
new file mode 100644
index 0000000..8f03db7
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/Error.hs
@@ -0,0 +1,41 @@
+module Crypto.Error (
+    CryptoError(..),
+    CryptoFailable(..),
+
+    throwCryptoErrorIO,
+    maybeCryptoError,
+) where
+
+import Control.Exception
+import Control.Monad
+
+
+data CryptoError = CryptoError
+    deriving (Show)
+
+instance Exception CryptoError
+
+data CryptoFailable a
+    = CryptoPassed a
+    | CryptoFailed CryptoError
+    deriving (Show)
+
+instance Functor CryptoFailable where
+    fmap f (CryptoPassed x) = CryptoPassed (f x)
+    fmap _ (CryptoFailed e) = CryptoFailed e
+
+instance Applicative CryptoFailable where
+    pure = CryptoPassed
+    (<*>) = ap
+
+instance Monad CryptoFailable where
+    CryptoPassed x >>= f = f x
+    CryptoFailed e >>= _ = CryptoFailed e
+
+throwCryptoErrorIO :: CryptoFailable a -> IO a
+throwCryptoErrorIO (CryptoPassed r) = return r
+throwCryptoErrorIO (CryptoFailed e) = throwIO e
+
+maybeCryptoError :: CryptoFailable a -> Maybe a
+maybeCryptoError (CryptoPassed x) = Just x
+maybeCryptoError (CryptoFailed _) = Nothing
diff --git a/src/crypto/reflibs/Crypto/Hash.hs b/src/crypto/reflibs/Crypto/Hash.hs
new file mode 100644
index 0000000..36308f9
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/Hash.hs
@@ -0,0 +1,80 @@
+module Crypto.Hash (
+    Digest,
+    Blake2b_256,
+
+    digestFromByteString,
+    hashInit,
+    hashUpdates,
+    hashFinalize,
+    hashDigestSize,
+) where
+
+import Control.DeepSeq
+import Control.Monad
+
+import Data.ByteArray
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Unsafe
+
+import Foreign.C.Types
+import Foreign.ForeignPtr
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import Foreign.Ptr
+import Foreign.Storable
+
+import System.IO.Unsafe
+
+
+newtype Digest a = Digest ByteString
+    deriving (Eq, Ord, NFData, ByteArrayAccess)
+
+data Context a = Context (ForeignPtr Blake2bContext)
+
+data Blake2bContext
+
+data Blake2b_256
+
+
+digestFromByteString :: ByteString -> Maybe (Digest Blake2b_256)
+digestFromByteString bs
+    | BS.length bs == digestSize = Just (Digest bs)
+    | otherwise                  = Nothing
+
+hashInit :: Context Blake2b_256
+hashInit = unsafePerformIO $ do
+    fctx <- mallocForeignPtrBytes stateSize
+    withForeignPtr fctx $ \ctx -> void $ cInit ctx (fromIntegral digestSize)
+    return $ Context fctx
+
+hashUpdates :: Context Blake2b_256 -> [ ByteString ] -> Context Blake2b_256
+hashUpdates (Context fbefore) updates = unsafePerformIO $ do
+    fafter <- mallocForeignPtrBytes stateSize
+    withForeignPtr fbefore $ \before ->
+        withForeignPtr fafter $ \after -> do
+            copyBytes after before stateSize
+            forM_ updates $ \update -> unsafeUseAsCStringLen update $ \( ptr, len ) -> do
+                void $ cUpdate after ptr (fromIntegral len)
+    return $ Context fafter
+
+hashFinalize :: Context Blake2b_256 -> Digest Blake2b_256
+hashFinalize (Context fctx) = unsafePerformIO $ do
+    bytes <- mallocBytes digestSize
+    withForeignPtr fctx $ \ctx ->
+        void $ cFinal ctx bytes (fromIntegral digestSize)
+    Digest <$> unsafePackMallocCStringLen ( bytes, digestSize )
+
+hashDigestSize :: Blake2b_256 -> Int
+hashDigestSize _ = fromIntegral digestSize
+
+digestSize :: Int
+digestSize = 32
+
+stateSize :: Int
+stateSize = fromIntegral $ unsafeDupablePerformIO $ peek cStateSize
+
+foreign import ccall unsafe "&blake2b_state_size" cStateSize :: Ptr CSize
+foreign import ccall unsafe "blake2b_init" cInit :: Ptr Blake2bContext -> CSize -> IO CInt
+foreign import ccall unsafe "blake2b_update" cUpdate :: Ptr Blake2bContext -> Ptr CChar -> CSize -> IO CInt
+foreign import ccall unsafe "blake2b_final" cFinal :: Ptr Blake2bContext -> Ptr CChar -> CSize -> IO CInt
diff --git a/src/crypto/reflibs/Crypto/MAC/Poly1305.hs b/src/crypto/reflibs/Crypto/MAC/Poly1305.hs
new file mode 100644
index 0000000..5e8938f
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/MAC/Poly1305.hs
@@ -0,0 +1,20 @@
+module Crypto.MAC.Poly1305 (
+    Auth(..),
+    authTag,
+) where
+
+import Crypto.Error
+
+import Data.ByteArray as BA
+import Data.ByteString (ByteString)
+
+
+newtype Auth = Auth ByteString
+    deriving (Eq, ByteArrayAccess)
+
+authTag :: ByteArrayAccess b => b -> CryptoFailable Auth
+authTag ba
+    | BA.length bs /= 16 = CryptoFailed CryptoError
+    | otherwise = CryptoPassed (Auth bs)
+  where
+    bs = convert ba
diff --git a/src/crypto/reflibs/Crypto/PubKey/Curve25519.hs b/src/crypto/reflibs/Crypto/PubKey/Curve25519.hs
new file mode 100644
index 0000000..ea8e035
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/PubKey/Curve25519.hs
@@ -0,0 +1,84 @@
+module Crypto.PubKey.Curve25519 (
+    CxSecretKey,
+    CxPublicKey,
+    DhSecret,
+
+    cxSecretKey,
+    cxPublicKey,
+
+    cxGenerateSecretKey,
+    cxToPublic,
+    diffieHellman,
+) where
+
+import Control.Monad
+
+import Crypto.Error
+import Crypto.Random
+
+import Data.Bits
+import Data.ByteArray
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Unsafe qualified as BS
+import Data.Word
+
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import Foreign.Ptr
+import Foreign.Storable
+
+import System.IO.Unsafe
+
+
+newtype CxSecretKey = CxSecretKey ByteString
+    deriving (Eq, ByteArrayAccess)
+
+newtype CxPublicKey = CxPublicKey ByteString
+    deriving (Eq, Show, ByteArrayAccess)
+
+newtype DhSecret = DhSecret ByteString
+    deriving (Eq, Show, ByteArrayAccess)
+
+cxSecretKey :: ByteArrayAccess bs => bs -> CryptoFailable CxSecretKey
+cxSecretKey ba
+    | BS.length bs == 32 = CryptoPassed $ CxSecretKey bs
+    | otherwise = CryptoFailed CryptoError
+  where
+    bs = convert ba
+
+cxPublicKey :: ByteString -> CryptoFailable CxPublicKey
+cxPublicKey bs
+    | BS.length bs == 32 = CryptoPassed $ CxPublicKey bs
+    | otherwise = CryptoFailed CryptoError
+
+cxGenerateSecretKey :: IO CxSecretKey
+cxGenerateSecretKey = do
+    bs <- getRandomBytes 32
+    BS.unsafeUseAsCString bs $ \ptr -> do
+        pokeElemOff ptr 0 . (.&. 248) =<< peekElemOff ptr 0
+        pokeElemOff ptr 31 . (.|. 64) . (.&. 127) =<< peekElemOff ptr 31
+    return $ CxSecretKey bs
+
+cxToPublic :: CxSecretKey -> CxPublicKey
+cxToPublic (CxSecretKey bs) = unsafePerformIO $ do
+    let len = 32
+    ptr <- mallocBytes len
+    BS.unsafeUseAsCString bs $ \secret -> do
+        allocaBytes 32 $ \basepoint -> do
+            fillBytes basepoint 0 len
+            pokeElemOff basepoint 0 9
+            void $ curve25519_donna ptr (castPtr secret) basepoint
+    CxPublicKey <$> BS.unsafePackCStringFinalizer ptr len (free ptr)
+
+diffieHellman :: CxPublicKey -> CxSecretKey -> DhSecret
+diffieHellman (CxPublicKey bpub) (CxSecretKey bsec) = unsafePerformIO $ do
+    let len = 32
+    ptr <- mallocBytes len
+    BS.unsafeUseAsCString bpub $ \pub -> do
+        BS.unsafeUseAsCString bsec $ \sec -> do
+            void $ curve25519_donna ptr (castPtr sec) (castPtr pub)
+    DhSecret <$> BS.unsafePackCStringFinalizer ptr len (free ptr)
+
+foreign import ccall unsafe "curve25519_donna" curve25519_donna :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO CInt
diff --git a/src/crypto/reflibs/Crypto/PubKey/Ed25519.hs b/src/crypto/reflibs/Crypto/PubKey/Ed25519.hs
new file mode 100644
index 0000000..88c7302
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/PubKey/Ed25519.hs
@@ -0,0 +1,73 @@
+module Crypto.PubKey.Ed25519 (
+    EdSecretKey,
+    EdPublicKey,
+    EdSignature,
+
+    edSecretKey,
+    edPublicKey,
+    edSignature,
+    edToPublic,
+    edGenerateSecretKey,
+    edSign,
+    edVerify,
+) where
+
+import Crypto.Error
+import Crypto.Random
+import Crypto.Sign.Ed25519 qualified as Ed
+
+import Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+
+
+newtype EdSecretKey = EdSecretKey { fromSecretKey :: Ed.SecretKey }
+    deriving (Eq)
+
+newtype EdPublicKey = EdPublicKey { fromPublicKey :: Ed.PublicKey }
+    deriving (Eq)
+
+newtype EdSignature = EdSignature { fromSignature :: Ed.Signature }
+    deriving (Eq)
+
+instance Show EdSecretKey where show = show . fromSecretKey
+instance Show EdPublicKey where show = show . fromPublicKey
+instance Show EdSignature where show = show . fromSignature
+
+instance ByteArrayAccess EdSecretKey where
+    length = BS.length . Ed.openSecretKey . fromSecretKey
+    withByteArray = withByteArray . Ed.openSecretKey . fromSecretKey
+
+instance ByteArrayAccess EdPublicKey where
+    length = BS.length . Ed.openPublicKey . fromPublicKey
+    withByteArray = withByteArray . Ed.openPublicKey . fromPublicKey
+
+instance ByteArrayAccess EdSignature where
+    length = BS.length . Ed.unSignature . fromSignature
+    withByteArray = withByteArray . Ed.unSignature . fromSignature
+
+signatureSize :: Int
+signatureSize = 64
+
+edSignature :: ByteString -> CryptoFailable EdSignature
+edSignature bs
+    | BS.length bs == signatureSize = CryptoPassed (EdSignature (Ed.Signature bs))
+    | otherwise = CryptoFailed CryptoError
+
+edPublicKey :: ByteString -> CryptoFailable EdPublicKey
+edPublicKey = maybe (CryptoFailed CryptoError) (CryptoPassed . EdPublicKey) . Ed.makePublicKey . convert
+
+edSecretKey :: ByteArrayAccess ba => ba -> CryptoFailable EdSecretKey
+edSecretKey = maybe (CryptoFailed CryptoError) (CryptoPassed . EdSecretKey) . Ed.makeSecretKey . convert
+
+edToPublic :: EdSecretKey -> EdPublicKey
+edToPublic = EdPublicKey . Ed.secretToPublicKey . fromSecretKey
+
+edSign :: ByteArrayAccess ba => EdSecretKey -> EdPublicKey -> ba -> EdSignature
+edSign (EdSecretKey key) _ = EdSignature . Ed.dsign key . convert
+
+edVerify :: ByteArrayAccess ba => EdPublicKey -> ba -> EdSignature -> Bool
+edVerify (EdPublicKey pub) msg (EdSignature sig) = Ed.dverify pub (convert msg) sig
+
+edGenerateSecretKey :: IO EdSecretKey
+edGenerateSecretKey = maybe (error "createKeypairFromSeed_ failed") (return . EdSecretKey . snd) . Ed.createKeypairFromSeed_ =<< getRandomBytes 32
diff --git a/src/crypto/reflibs/Crypto/Random.hs b/src/crypto/reflibs/Crypto/Random.hs
new file mode 100644
index 0000000..6297155
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/Random.hs
@@ -0,0 +1,13 @@
+module Crypto.Random (
+    MonadRandom(..),
+) where
+
+import Crypto.Random.Entropy
+
+import Data.ByteArray
+
+class Monad m => MonadRandom m where
+    getRandomBytes :: ByteArray byteArray => Int -> m byteArray
+
+instance MonadRandom IO where
+    getRandomBytes = fmap convert . getEntropy
diff --git a/src/crypto/reflibs/Crypto/Random/Entropy.hs b/src/crypto/reflibs/Crypto/Random/Entropy.hs
new file mode 100644
index 0000000..d0685e4
--- /dev/null
+++ b/src/crypto/reflibs/Crypto/Random/Entropy.hs
@@ -0,0 +1,19 @@
+module Crypto.Random.Entropy (
+    getEntropy,
+) where
+
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Unsafe
+
+getEntropy :: Int -> IO ByteString
+getEntropy n = do
+    bytes <- mallocBytes n
+    throwErrnoIfMinus1_ "getentropy" $ c_getentropy bytes (fromIntegral n)
+    unsafePackMallocCStringLen ( bytes, n )
+
+foreign import ccall "unistd.h getentropy" c_getentropy :: Ptr CChar -> CSize -> IO CInt