From 41cde99ec6189dbecca6803a5aa4f6f18142e8ba Mon Sep 17 00:00:00 2001
From: Haskell Guy <haskell.guy@localhost>
Date: Tue, 26 May 2020 13:07:50 +0200
Subject: initial commit

---
 src/Sodium.hs | 99 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)
 create mode 100644 src/Sodium.hs

(limited to 'src/Sodium.hs')

diff --git a/src/Sodium.hs b/src/Sodium.hs
new file mode 100644
index 0000000..eb11bb2
--- /dev/null
+++ b/src/Sodium.hs
@@ -0,0 +1,99 @@
+-- | This module implements additional bindings for libsodium which are
+-- required for the SSB handshake.
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Sodium where
+
+import           Data.ByteString.Unsafe
+import qualified Data.ByteString                   as BS
+import Protolude
+import           Foreign.C
+import           Foreign.Ptr
+import           Foreign.Marshal.Alloc
+import           Foreign.Storable
+import           System.IO.Unsafe
+
+import qualified Crypto.Saltine.Internal.ByteSizes as Bytes
+import Crypto.Saltine.Class
+import qualified Crypto.Saltine.Core.Box as Box
+import qualified Crypto.Saltine.Core.Sign as Sign
+
+foreign import ccall "crypto_sign_ed25519_sk_to_curve25519"
+  c_sign_ed25519_sk_to_curve25519 :: Ptr CChar
+                                  -- ^ Converted Curve25519 secret key buffer
+                                  -> Ptr CChar
+                                  -- ^ Ed25519 secret key buffer
+                                  -> IO CInt
+                                  -- ^ Always 0
+
+foreign import ccall "crypto_sign_ed25519_pk_to_curve25519"
+  c_sign_ed25519_pk_to_curve25519 :: Ptr CChar
+                                  -- ^ Converted Curve25519 public key buffer
+                                  -> Ptr CChar
+                                  -- ^ Ed25519 public key buffer
+                                  -> IO CInt
+                                  -- ^ Always 0
+
+
+-- | Size of a @curve_25519@-generated secret key
+curve25519SK    = 64
+
+newtype Curve25519SecretKey = CSK ByteString deriving (Eq, Ord)
+
+instance IsEncoding Curve25519SecretKey where
+  decode v = if BS.length v == curve25519SK
+           then Just (CSK v)
+           else Nothing
+  {-# INLINE decode #-}
+  encode (CSK v) = v
+  {-# INLINE encode #-}
+
+secretKeyToCurve25519 :: Sign.SecretKey -> Curve25519SecretKey
+secretKeyToCurve25519 sk = unsafePerformIO $ do
+    (_err, csk) <-  buildUnsafeByteString' curve25519PK $ \cskbuf ->
+      constByteStrings [skbuf] $ \[(skbuf', _)] ->
+        c_sign_ed25519_sk_to_curve25519 cskbuf skbuf'
+    return $ CSK csk
+  where
+    skbuf = encode sk :: ByteString
+
+-- | Size of a @curve_25519@-generated public key
+curve25519PK    = 32
+
+newtype Curve25519PublicKey = CPK ByteString deriving (Eq, Ord)
+
+instance IsEncoding Curve25519PublicKey where
+  decode v = if BS.length v == curve25519PK
+           then Just (CPK v)
+           else Nothing
+  {-# INLINE decode #-}
+  encode (CPK v) = v
+  {-# INLINE encode #-}
+
+
+publicKeyToCurve25519 :: Box.PublicKey -> Curve25519PublicKey
+publicKeyToCurve25519 pk = unsafePerformIO $ do
+    (_err, cpk) <-  buildUnsafeByteString' curve25519PK $ \cpkbuf ->
+      constByteStrings [pkbuf] $ \[(pkbuf', _)] ->
+        c_sign_ed25519_pk_to_curve25519 cpkbuf pkbuf'
+    return $ CPK cpk
+  where
+    pkbuf = encode pk :: ByteString
+
+-- | Copied from Saltine :)
+
+-- | Convenience function for accessing constant C strings
+constByteStrings :: [ByteString] -> ([CStringLen] -> IO b) -> IO b
+constByteStrings =
+  foldr (\v kk -> \k -> (unsafeUseAsCStringLen v) (\a -> kk (\as -> k (a:as)))) ($ [])
+
+-- | Slightly safer cousin to 'buildUnsafeByteString' that remains in the
+-- 'IO' monad.
+buildUnsafeByteString' :: Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
+buildUnsafeByteString' n k = do
+  ph  <- mallocBytes n
+  bs  <- unsafePackMallocCStringLen (ph, fromIntegral n)
+  out <- unsafeUseAsCString bs k
+  return (out, bs)
+
-- 
cgit v1.2.3