-- | 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)