-- |An implementation of the core methods of the elliptic curve Curve25519
-- suite. These functions are largely wrappers over the curve25519-donna
-- library from Google. While this version is theoretically pure, in that
-- it doesn't generate any exceptions, you should be warned that it uses
-- unsafePerformIO under the hood.
module Crypto.Curve25519.Pure(
         PrivateKey
       , PublicKey
       , importPublic, exportPublic
       , importPrivate, exportPrivate
       , generatePrivate
       , generatePublic
       , generateKeyPair
       , makeShared
       )
 where

import Crypto.Random
import Data.Bits
import Data.ByteString(ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe
import Data.Word
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Ptr
import System.IO.Unsafe
import Data.Maybe (fromJust)
import Data.List (foldl')

-- |The type of a Curve25519 private key.
newtype PrivateKey = Priv ByteString

-- |The type of a Curve25519 public key.
newtype PublicKey  = Pub  ByteString

instance Show PrivateKey where
  show :: PrivateKey -> String
show (Priv ByteString
x) = Integer -> String
forall a. Show a => a -> String
show (ByteString -> Integer
buildNumber ByteString
x)

instance Show PublicKey where
  show :: PublicKey -> String
show (Pub ByteString
x) = Integer -> String
forall a. Show a => a -> String
show (ByteString -> Integer
buildNumber ByteString
x)

-- |Randomly generate a Curve25519 private key.
generatePrivate :: CryptoRandomGen g => g -> Either GenError (PrivateKey, g)
generatePrivate :: g -> Either GenError (PrivateKey, g)
generatePrivate g
g =
  case Int -> g -> Either GenError (ByteString, g)
forall g.
CryptoRandomGen g =>
Int -> g -> Either GenError (ByteString, g)
genBytes Int
32 g
g of
    Left GenError
e              -> GenError -> Either GenError (PrivateKey, g)
forall a b. a -> Either a b
Left GenError
e
    Right (ByteString
bytesbs, g
g') -> (PrivateKey, g) -> Either GenError (PrivateKey, g)
forall a b. b -> Either a b
Right (Maybe PrivateKey -> PrivateKey
forall a. HasCallStack => Maybe a -> a
fromJust (ByteString -> Maybe PrivateKey
importPrivate ByteString
bytesbs), g
g')

-- | Imports a 'ByteString' to use as private key.
-- The 'ByteString' must be exactly 32 bytes long for this to work.
--
-- Though minor changes may be made to create a valid key this property is guaranteed:
-- prop> (\x -> importPrivate x >>= (importPrivate . exportPrivate)) = importPrivate
importPrivate :: ByteString -> Maybe PrivateKey
importPrivate :: ByteString -> Maybe PrivateKey
importPrivate ByteString
bstr
  | ByteString -> Int
BS.length ByteString
bstr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
32 = Maybe PrivateKey
forall a. Maybe a
Nothing
  | Bool
otherwise  = 
    let Just (Word8
b0, ByteString
b1_31)  = ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bstr
        Just (ByteString
b1_30, Word8
b31) = ByteString -> Maybe (ByteString, Word8)
BS.unsnoc ByteString
b1_31
        b0' :: Word8
b0'               = Word8
b0   Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
248
        b31' :: Word8
b31'              = Word8
b31  Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
127
        b31'' :: Word8
b31''             = Word8
b31' Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
64
        bytes :: ByteString
bytes             = (Word8
b0' Word8 -> ByteString -> ByteString
`BS.cons` ByteString
b1_30) ByteString -> Word8 -> ByteString
`BS.snoc` Word8
b31''
    in PrivateKey -> Maybe PrivateKey
forall a. a -> Maybe a
Just (PrivateKey -> Maybe PrivateKey) -> PrivateKey -> Maybe PrivateKey
forall a b. (a -> b) -> a -> b
$ ByteString -> PrivateKey
Priv ByteString
bytes

-- | Export a private key to a 'ByteString'
exportPrivate :: PrivateKey -> ByteString
exportPrivate :: PrivateKey -> ByteString
exportPrivate (Priv ByteString
bstr) = ByteString
bstr


-- |Randomly generate a Curve25519 public key.
generatePublic :: PrivateKey -> PublicKey
generatePublic :: PrivateKey -> PublicKey
generatePublic (Priv ByteString
priv) = ByteString -> PublicKey
Pub (ByteString -> ByteString -> ByteString
curve25519 ByteString
priv ByteString
basePoint)

-- |Import a public key from a 'ByteString'.
-- The 'ByteString' must be exactly 32 bytes long for this to work.
importPublic :: ByteString -> Maybe PublicKey
importPublic :: ByteString -> Maybe PublicKey
importPublic ByteString
bstr | ByteString -> Int
BS.length ByteString
bstr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 = PublicKey -> Maybe PublicKey
forall a. a -> Maybe a
Just (ByteString -> PublicKey
Pub ByteString
bstr)
                  | Bool
otherwise            = Maybe PublicKey
forall a. Maybe a
Nothing

-- |Export a public key to a 'ByteString'.
exportPublic :: PublicKey -> ByteString
exportPublic :: PublicKey -> ByteString
exportPublic (Pub ByteString
bstr) = ByteString
bstr

-- |Randomly generate a key pair.
generateKeyPair :: CryptoRandomGen g =>
                   g ->
                   Either GenError (PrivateKey, PublicKey, g)
generateKeyPair :: g -> Either GenError (PrivateKey, PublicKey, g)
generateKeyPair g
g =
  case g -> Either GenError (PrivateKey, g)
forall g. CryptoRandomGen g => g -> Either GenError (PrivateKey, g)
generatePrivate g
g of
   Left GenError
e           -> GenError -> Either GenError (PrivateKey, PublicKey, g)
forall a b. a -> Either a b
Left GenError
e
   Right (PrivateKey
priv, g
g') -> (PrivateKey, PublicKey, g)
-> Either GenError (PrivateKey, PublicKey, g)
forall a b. b -> Either a b
Right (PrivateKey
priv, PrivateKey -> PublicKey
generatePublic PrivateKey
priv, g
g')

-- |Generate a shared secret from a private key and a public key.
makeShared :: PrivateKey -> PublicKey -> ByteString
makeShared :: PrivateKey -> PublicKey -> ByteString
makeShared (Priv ByteString
a) (Pub ByteString
b) = ByteString -> ByteString -> ByteString
curve25519 ByteString
a ByteString
b

-- Internal. A moderately evil wrapper over the core C routine.
curve25519 :: ByteString -> ByteString -> ByteString
curve25519 :: ByteString -> ByteString -> ByteString
curve25519 ByteString
a ByteString
b =
  IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    ByteString -> (CString -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString ByteString
a ((CString -> IO ByteString) -> IO ByteString)
-> (CString -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ CString
ptra ->
      ByteString -> (CString -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString ByteString
b ((CString -> IO ByteString) -> IO ByteString)
-> (CString -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ CString
ptrb ->
        do Ptr Word8
ptrc <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
32
           Ptr Word8 -> CString -> CString -> IO ()
curve25519_donna Ptr Word8
ptrc CString
ptra CString
ptrb
           Ptr Word8 -> Int -> IO () -> IO ByteString
unsafePackCStringFinalizer Ptr Word8
ptrc Int
32 (Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
ptrc)

basePoint :: ByteString
basePoint :: ByteString
basePoint = Word8 -> ByteString -> ByteString
BS.cons Word8
9 (Int -> Word8 -> ByteString
BS.replicate Int
31 Word8
0)

buildNumber :: ByteString -> Integer
buildNumber :: ByteString -> Integer
buildNumber ByteString
bstr = (Integer -> Word8 -> Integer) -> Integer -> [Word8] -> Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Integer -> Word8 -> Integer
forall a a. (Bits a, Integral a, Num a) => a -> a -> a
run Integer
0 (ByteString -> [Word8]
BS.unpack ByteString
bstr)
 where
  run :: a -> a -> a
run a
acc a
x = (a
acc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x

foreign import ccall unsafe
  curve25519_donna :: Ptr Word8 -> Ptr CChar -> Ptr CChar -> IO ()