path: root/ToxCrypto.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE TypeOperators #-}
module ToxCrypto
    ( PublicKey
    , publicKey
    , getPublicKey
    , putPublicKey
    , SecretKey
    , SymmetricKey(..)
    , TransportCrypto(..)
    , Encrypted
    , Encrypted8(..)
    , type (∘)(..)
    , Assym(..)
    , getAssym
    , getAliasedAssym
    , putAssym
    , putAliasedAssym
    , Plain
    , encodePlain
    , decodePlain
    , computeSharedSecret
    , encrypt
    , decrypt
    , Nonce8(..)
    , Nonce24(..)
    , Nonce32(..)
    , getRemainingEncrypted
    , putEncrypted
    , Auth
    , Sized(..)
    , Size(..)
    , State(..)
    , zeros32
    , zeros24
    , decryptSymmetric
    , encryptSymmetric
    ) where

import Control.Arrow
import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
import qualified Crypto.Cipher.Salsa    as Salsa
import qualified Crypto.Cipher.XSalsa   as XSalsa
import Crypto.ECC.Class
import qualified Crypto.Error           as Cryptonite
import qualified Crypto.MAC.Poly1305    as Poly1305
import Crypto.PubKey.Curve25519
import qualified Data.ByteArray         as BA
         ;import Data.ByteArray         as BA (ByteArrayAccess, Bytes)
import Data.ByteString                  as B
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8  as C8
import Data.Data
import Data.Functor.Contravariant
import Data.Kind
import Data.Ord
import Data.Serialize as S
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.Endian
import qualified Data.ByteString.Internal
import Control.Concurrent.STM
import Crypto.Error.Types                     (CryptoFailable (..), throwCryptoError)

-- | A 16-byte mac and an arbitrary-length encrypted stream.
newtype Encrypted a = Encrypted ByteString
 deriving (Eq,Ord,Data)

newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
 deriving Serialize

newtype (f ∘ g) x = Composed { uncomposed :: f (g x) }

newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
instance Ord Auth where
    compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
instance Data Auth where
    gfoldl k z x = z x
    -- Well, this is a little wonky... XXX
    gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
    toConstr _ = con_Auth
    dataTypeOf _ = mkDataType "ToxMessage" [con_Auth]
con_Auth :: Constr
con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
instance Serialize Auth where
    get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
    put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs

instance Typeable a => Show (Encrypted a) where
    show (Encrypted _) = "Encrypted "++show (typeOf (undefined :: a))

encryptedAuth :: Encrypted a -> Auth
encryptedAuth (Encrypted bs)
    | Right auth <- decode (B.take 16 bs) = auth
    | otherwise                           = error "encryptedAuth: insufficient bytes"

authAndBytes :: Encrypted a -> (Auth, ByteString)
authAndBytes (Encrypted bs) = (auth,bs')
 where
    (as,bs')   = B.splitAt 16 bs
    Right auth = decode as

-- | Info about a type's serialized length. Either the length is known
-- independently of the value, or the length depends on the value.
data Size a
    = VarSize (a -> Int)
    | ConstSize !Int
    deriving Typeable

instance Contravariant Size where
  contramap f sz = case sz of
      ConstSize n -> ConstSize n
      VarSize g   -> VarSize (\x -> g (f x))

instance Monoid (Size a) where
    ConstSize x `mappend` ConstSize y = ConstSize (x + y)
    VarSize f   `mappend` ConstSize y = VarSize $ \x -> f x + y
    ConstSize x `mappend` VarSize g   = VarSize $ \y -> x + g y
    VarSize f   `mappend` VarSize g   = VarSize $ \x -> f x + g x
    mempty = ConstSize 0


class Sized a where size :: Size a

instance Sized a => Serialize (Encrypted a) where
    get = case size :: Size a of
            VarSize _   -> Encrypted <$> (remaining >>= getBytes)
            ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac
    put = putEncrypted

instance Sized a => Sized (Encrypted a) where
    size = case size :: Size a of
        ConstSize n -> ConstSize $ n + 16
        VarSize _   -> VarSize $ \(Encrypted bs) -> B.length bs

instance (Sized a, Sized b) => Sized (a,b) where
    size = case (size :: Size a, size :: Size b) of
        (ConstSize a , ConstSize b) -> ConstSize $ a + b
        (VarSize f   , ConstSize b) -> VarSize $ \(a, _) -> f a + b
        (ConstSize a , VarSize g)   -> VarSize $ \(_, b) -> a + g b
        (VarSize f   , VarSize g)   -> VarSize $ \(a, b) -> f a + g b

getRemainingEncrypted :: Get (Encrypted a)
getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes)

putEncrypted :: Encrypted a -> Put
putEncrypted (Encrypted bs) = putByteString bs

newtype Plain (s:: * -> Constraint) a = Plain ByteString


decodePlain :: Serialize a => Plain Serialize a -> Either String a
decodePlain (Plain bs) = decode bs

encodePlain :: Serialize a => a -> Plain Serialize a
encodePlain a = Plain $ encode a

storePlain :: Storable a => a -> IO (Plain Storable a)
storePlain a = Plain <$> BA.create (sizeOf a) (`poke` a)

retrievePlain :: Storable a => Plain Storable a -> IO a
retrievePlain (Plain bs) = BA.withByteArray bs peek

decryptSymmetric :: SymmetricKey -> Nonce24 -> Encrypted a -> Either String (Plain s a)
decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do
    let sym_nonce_bytes = B.take 12 n24
        (mac, bs'')     = B.splitAt 16 bs
    symm <- left show . Cryptonite.eitherCryptoError $ do
        sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
        Symmetric.initialize symmkey sym_nonce
    let (ds, symm') = Symmetric.decrypt bs'' symm
        auth = Symmetric.finalize symm'
    if BA.convert auth /= mac
        then Left "symmetricDecipher: Auth fail."
        else return $ Plain ds

encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x
encryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Plain bs) = Encrypted es
 where
    Cryptonite.CryptoPassed es = do
        sym_nonce <- Symmetric.nonce12 (BA.take 12 n24)
        symm <- Symmetric.initialize symmkey sym_nonce
        let (rpath_bs, symm') = Symmetric.encrypt bs symm
            auth = Symmetric.finalize symm' -- 16 bytes
        return (BA.convert auth `BA.append` rpath_bs)


data State = State Poly1305.State XSalsa.State

decrypt :: State -> Encrypted a -> Either String (Plain s a)
decrypt (State hash crypt) ciphertext
    | (a == mac) = Right (Plain m)
    | otherwise  = Left "decipherAndAuth: auth fail"
  where
    (mac, c) = authAndBytes ciphertext
    m = fst . XSalsa.combine crypt $ c
    a = Auth . Poly1305.finalize . Poly1305.update hash $ c

-- Encrypt-then-Mac:  Encrypt the cleartext, then compute the MAC on the
-- ciphertext, and prepend it to the ciphertext
encrypt :: State -> Plain s a -> Encrypted a
encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c
  where
    c = fst . XSalsa.combine crypt $ m
    a = Auth . Poly1305.finalize . Poly1305.update hash $ c

-- (Poly1305.State, XSalsa.State)
computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State
computeSharedSecret sk recipient nonce = State hash crypt
 where
    -- diffie helman
    shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
    -- shared secret XSalsa key
    k = hsalsa20 shared zeros24
    -- cipher state
    st0 = XSalsa.initialize 20 k nonce
    -- Poly1305 key
    (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
    -- Since rs is 32 bytes, this pattern should never fail...
    Cryptonite.CryptoPassed hash = Poly1305.initialize rs

hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
hsalsa20 k n = BA.append a b
 where
    Salsa.State st = XSalsa.initialize 20 k n
    (_, as) = BA.splitAt 4 st
    (a, xs) = BA.splitAt 16 as
    (_, bs) = BA.splitAt 24 xs
    (b, _ ) = BA.splitAt 16 bs


newtype Nonce24 = Nonce24 ByteString
 deriving (Eq, Ord, ByteArrayAccess,Data)

quoted :: ShowS -> ShowS
quoted shows s = '"':shows ('"':s)

bin2hex :: ByteArrayAccess bs => bs -> String
bin2hex = C8.unpack . Base16.encode . BA.convert

instance Show Nonce24 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)

instance Sized Nonce24 where size = ConstSize 24

instance Serialize Nonce24 where
    get = Nonce24 <$> getBytes 24
    put (Nonce24 bs) = putByteString bs

newtype Nonce8 = Nonce8 Word64
 deriving (Eq, Ord, Data, Serialize)

-- Note: Big-endian to match Serialize instance.
instance Storable Nonce8 where
    sizeOf _ = 8
    alignment _ = alignment (undefined::Word64)
    peek ptr = Nonce8 . fromBE64 <$> peek (castPtr ptr)
    poke ptr (Nonce8 w) = poke (castPtr ptr) (toBE64 w)

instance Sized Nonce8 where size = ConstSize 8

instance ByteArrayAccess Nonce8 where
    length _ = 8
    withByteArray (Nonce8 w64) kont =
        allocaBytes 8 $ \p -> do
            poke (castPtr p :: Ptr Word64) $ toBE64 w64
            kont p

instance Show Nonce8 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)


newtype Nonce32 = Nonce32 ByteString
 deriving (Eq, Ord, ByteArrayAccess, Data)

instance Show Nonce32 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)

instance Serialize Nonce32 where
    get = Nonce32 <$> getBytes 32
    put (Nonce32 bs) = putByteString bs

instance Sized Nonce32 where size = ConstSize 32


zeros32 :: Nonce32
zeros32 = Nonce32 $ BA.replicate 32 0

zeros24 :: ByteString
zeros24 = BA.take 24 zs where Nonce32 zs = zeros32

-- | `32`   | sender's DHT public key   |
-- | `24`   | nonce                     |
-- | `?`    | encrypted message         |
data Assym a = Assym
    { senderKey :: PublicKey
    , assymNonce :: Nonce24
    , assymData :: a
    }
 deriving (Functor,Foldable,Traversable, Show)

instance Sized a => Sized (Assym a) where
    size = case size of
        ConstSize a -> ConstSize $ a + 24 + 32
        VarSize f   -> VarSize $ \Assym { assymData = x } -> f x + 24 + 32

-- | Field order: senderKey, then nonce This is the format used by
-- Ping/Pong/GetNodes/SendNodes.
--
-- See 'getAliasedAssym' if the nonce precedes the key.
getAssym :: Serialize a => Get (Assym a)
getAssym = Assym <$> getPublicKey <*> get <*> get

putAssym :: Serialize a => Assym a -> Put
putAssym (Assym key nonce dta) = putPublicKey key >> put nonce >> put dta

-- | Field order: nonce, and then senderKey.
getAliasedAssym :: Serialize a => Get (Assym a)
getAliasedAssym = flip Assym <$> get <*> getPublicKey <*> get

putAliasedAssym :: Serialize a => Assym a -> Put
putAliasedAssym (Assym key nonce dta) = put nonce >> putPublicKey key >> put dta

newtype SymmetricKey = SymmetricKey ByteString

data TransportCrypto = TransportCrypto
    { transportSecret :: SecretKey
    , transportPublic :: PublicKey
    , transportSymmetric :: STM SymmetricKey
    , transportNewNonce :: STM Nonce24
    }

getPublicKey :: S.Get PublicKey
getPublicKey = throwCryptoError . publicKey <$> S.getBytes 32

putPublicKey :: PublicKey -> S.Put
putPublicKey bs = S.putByteString $ BA.convert bs