summaryrefslogtreecommitdiff
path: root/src/Crypto
diff options
context:
space:
mode:
Diffstat (limited to 'src/Crypto')
-rw-r--r--src/Crypto/Tox.hs346
1 files changed, 346 insertions, 0 deletions
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs
new file mode 100644
index 00000000..c745270d
--- /dev/null
+++ b/src/Crypto/Tox.hs
@@ -0,0 +1,346 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveTraversable #-}
7{-# LANGUAGE ExplicitNamespaces #-}
8{-# LANGUAGE TypeOperators #-}
9module Crypto.Tox
10 ( PublicKey
11 , publicKey
12 , getPublicKey
13 , putPublicKey
14 , SecretKey
15 , SymmetricKey(..)
16 , TransportCrypto(..)
17 , Encrypted
18 , Encrypted8(..)
19 , type (∘)(..)
20 , Assym(..)
21 , getAssym
22 , getAliasedAssym
23 , putAssym
24 , putAliasedAssym
25 , Plain
26 , encodePlain
27 , decodePlain
28 , computeSharedSecret
29 , encrypt
30 , decrypt
31 , Nonce8(..)
32 , Nonce24(..)
33 , Nonce32(..)
34 , getRemainingEncrypted
35 , putEncrypted
36 , Auth
37 , Sized(..)
38 , Size(..)
39 , State(..)
40 , zeros32
41 , zeros24
42 , decryptSymmetric
43 , encryptSymmetric
44 ) where
45
46import Control.Arrow
47import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
48import qualified Crypto.Cipher.Salsa as Salsa
49import qualified Crypto.Cipher.XSalsa as XSalsa
50import Crypto.ECC.Class
51import qualified Crypto.Error as Cryptonite
52import qualified Crypto.MAC.Poly1305 as Poly1305
53import Crypto.PubKey.Curve25519
54import qualified Data.ByteArray as BA
55 ;import Data.ByteArray as BA (ByteArrayAccess, Bytes)
56import Data.ByteString as B
57import qualified Data.ByteString.Base16 as Base16
58import qualified Data.ByteString.Char8 as C8
59import Data.Data
60import Data.Functor.Contravariant
61import Data.Kind
62import Data.Ord
63import Data.Serialize as S
64import Data.Word
65import Foreign.Marshal.Alloc
66import Foreign.Ptr
67import Foreign.Storable
68import System.Endian
69import qualified Data.ByteString.Internal
70import Control.Concurrent.STM
71import Crypto.Error.Types (CryptoFailable (..), throwCryptoError)
72
73-- | A 16-byte mac and an arbitrary-length encrypted stream.
74newtype Encrypted a = Encrypted ByteString
75 deriving (Eq,Ord,Data)
76
77newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
78 deriving Serialize
79
80newtype (f ∘ g) x = Composed { uncomposed :: f (g x) }
81
82newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
83instance Ord Auth where
84 compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
85instance Data Auth where
86 gfoldl k z x = z x
87 -- Well, this is a little wonky... XXX
88 gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
89 toConstr _ = con_Auth
90 dataTypeOf _ = mkDataType "ToxCrypto" [con_Auth]
91con_Auth :: Constr
92con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
93instance Serialize Auth where
94 get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
95 put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs
96
97instance Typeable a => Show (Encrypted a) where
98 show (Encrypted _) = "Encrypted "++show (typeOf (undefined :: a))
99
100encryptedAuth :: Encrypted a -> Auth
101encryptedAuth (Encrypted bs)
102 | Right auth <- decode (B.take 16 bs) = auth
103 | otherwise = error "encryptedAuth: insufficient bytes"
104
105authAndBytes :: Encrypted a -> (Auth, ByteString)
106authAndBytes (Encrypted bs) = (auth,bs')
107 where
108 (as,bs') = B.splitAt 16 bs
109 Right auth = decode as
110
111-- | Info about a type's serialized length. Either the length is known
112-- independently of the value, or the length depends on the value.
113data Size a
114 = VarSize (a -> Int)
115 | ConstSize !Int
116 deriving Typeable
117
118instance Contravariant Size where
119 contramap f sz = case sz of
120 ConstSize n -> ConstSize n
121 VarSize g -> VarSize (\x -> g (f x))
122
123instance Monoid (Size a) where
124 ConstSize x `mappend` ConstSize y = ConstSize (x + y)
125 VarSize f `mappend` ConstSize y = VarSize $ \x -> f x + y
126 ConstSize x `mappend` VarSize g = VarSize $ \y -> x + g y
127 VarSize f `mappend` VarSize g = VarSize $ \x -> f x + g x
128 mempty = ConstSize 0
129
130
131class Sized a where size :: Size a
132
133instance Sized a => Serialize (Encrypted a) where
134 get = case size :: Size a of
135 VarSize _ -> Encrypted <$> (remaining >>= getBytes)
136 ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac
137 put = putEncrypted
138
139instance Sized a => Sized (Encrypted a) where
140 size = case size :: Size a of
141 ConstSize n -> ConstSize $ n + 16
142 VarSize _ -> VarSize $ \(Encrypted bs) -> B.length bs
143
144instance (Sized a, Sized b) => Sized (a,b) where
145 size = case (size :: Size a, size :: Size b) of
146 (ConstSize a , ConstSize b) -> ConstSize $ a + b
147 (VarSize f , ConstSize b) -> VarSize $ \(a, _) -> f a + b
148 (ConstSize a , VarSize g) -> VarSize $ \(_, b) -> a + g b
149 (VarSize f , VarSize g) -> VarSize $ \(a, b) -> f a + g b
150
151getRemainingEncrypted :: Get (Encrypted a)
152getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes)
153
154putEncrypted :: Encrypted a -> Put
155putEncrypted (Encrypted bs) = putByteString bs
156
157newtype Plain (s:: * -> Constraint) a = Plain ByteString
158
159
160decodePlain :: Serialize a => Plain Serialize a -> Either String a
161decodePlain (Plain bs) = decode bs
162
163encodePlain :: Serialize a => a -> Plain Serialize a
164encodePlain a = Plain $ encode a
165
166storePlain :: Storable a => a -> IO (Plain Storable a)
167storePlain a = Plain <$> BA.create (sizeOf a) (`poke` a)
168
169retrievePlain :: Storable a => Plain Storable a -> IO a
170retrievePlain (Plain bs) = BA.withByteArray bs peek
171
172decryptSymmetric :: SymmetricKey -> Nonce24 -> Encrypted a -> Either String (Plain s a)
173decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do
174 let sym_nonce_bytes = B.take 12 n24
175 (mac, bs'') = B.splitAt 16 bs
176 symm <- left show . Cryptonite.eitherCryptoError $ do
177 sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
178 Symmetric.initialize symmkey sym_nonce
179 let (ds, symm') = Symmetric.decrypt bs'' symm
180 auth = Symmetric.finalize symm'
181 if BA.convert auth /= mac
182 then Left "symmetricDecipher: Auth fail."
183 else return $ Plain ds
184
185encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x
186encryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Plain bs) = Encrypted es
187 where
188 Cryptonite.CryptoPassed es = do
189 sym_nonce <- Symmetric.nonce12 (BA.take 12 n24)
190 symm <- Symmetric.initialize symmkey sym_nonce
191 let (rpath_bs, symm') = Symmetric.encrypt bs symm
192 auth = Symmetric.finalize symm' -- 16 bytes
193 return (BA.convert auth `BA.append` rpath_bs)
194
195
196data State = State Poly1305.State XSalsa.State
197
198decrypt :: State -> Encrypted a -> Either String (Plain s a)
199decrypt (State hash crypt) ciphertext
200 | (a == mac) = Right (Plain m)
201 | otherwise = Left "decipherAndAuth: auth fail"
202 where
203 (mac, c) = authAndBytes ciphertext
204 m = fst . XSalsa.combine crypt $ c
205 a = Auth . Poly1305.finalize . Poly1305.update hash $ c
206
207-- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the
208-- ciphertext, and prepend it to the ciphertext
209encrypt :: State -> Plain s a -> Encrypted a
210encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c
211 where
212 c = fst . XSalsa.combine crypt $ m
213 a = Auth . Poly1305.finalize . Poly1305.update hash $ c
214
215-- (Poly1305.State, XSalsa.State)
216computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State
217computeSharedSecret sk recipient nonce = State hash crypt
218 where
219 -- diffie helman
220 shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
221 -- shared secret XSalsa key
222 k = hsalsa20 shared zeros24
223 -- cipher state
224 st0 = XSalsa.initialize 20 k nonce
225 -- Poly1305 key
226 (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
227 -- Since rs is 32 bytes, this pattern should never fail...
228 Cryptonite.CryptoPassed hash = Poly1305.initialize rs
229
230hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
231hsalsa20 k n = BA.append a b
232 where
233 Salsa.State st = XSalsa.initialize 20 k n
234 (_, as) = BA.splitAt 4 st
235 (a, xs) = BA.splitAt 16 as
236 (_, bs) = BA.splitAt 24 xs
237 (b, _ ) = BA.splitAt 16 bs
238
239
240newtype Nonce24 = Nonce24 ByteString
241 deriving (Eq, Ord, ByteArrayAccess,Data)
242
243quoted :: ShowS -> ShowS
244quoted shows s = '"':shows ('"':s)
245
246bin2hex :: ByteArrayAccess bs => bs -> String
247bin2hex = C8.unpack . Base16.encode . BA.convert
248
249instance Show Nonce24 where
250 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
251
252instance Sized Nonce24 where size = ConstSize 24
253
254instance Serialize Nonce24 where
255 get = Nonce24 <$> getBytes 24
256 put (Nonce24 bs) = putByteString bs
257
258newtype Nonce8 = Nonce8 Word64
259 deriving (Eq, Ord, Data, Serialize)
260
261-- Note: Big-endian to match Serialize instance.
262instance Storable Nonce8 where
263 sizeOf _ = 8
264 alignment _ = alignment (undefined::Word64)
265 peek ptr = Nonce8 . fromBE64 <$> peek (castPtr ptr)
266 poke ptr (Nonce8 w) = poke (castPtr ptr) (toBE64 w)
267
268instance Sized Nonce8 where size = ConstSize 8
269
270instance ByteArrayAccess Nonce8 where
271 length _ = 8
272 withByteArray (Nonce8 w64) kont =
273 allocaBytes 8 $ \p -> do
274 poke (castPtr p :: Ptr Word64) $ toBE64 w64
275 kont p
276
277instance Show Nonce8 where
278 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
279
280
281newtype Nonce32 = Nonce32 ByteString
282 deriving (Eq, Ord, ByteArrayAccess, Data)
283
284instance Show Nonce32 where
285 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
286
287instance Serialize Nonce32 where
288 get = Nonce32 <$> getBytes 32
289 put (Nonce32 bs) = putByteString bs
290
291instance Sized Nonce32 where size = ConstSize 32
292
293
294zeros32 :: Nonce32
295zeros32 = Nonce32 $ BA.replicate 32 0
296
297zeros24 :: ByteString
298zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
299
300-- | `32` | sender's DHT public key |
301-- | `24` | nonce |
302-- | `?` | encrypted message |
303data Assym a = Assym
304 { senderKey :: PublicKey
305 , assymNonce :: Nonce24
306 , assymData :: a
307 }
308 deriving (Functor,Foldable,Traversable, Show)
309
310instance Sized a => Sized (Assym a) where
311 size = case size of
312 ConstSize a -> ConstSize $ a + 24 + 32
313 VarSize f -> VarSize $ \Assym { assymData = x } -> f x + 24 + 32
314
315-- | Field order: senderKey, then nonce This is the format used by
316-- Ping/Pong/GetNodes/SendNodes.
317--
318-- See 'getAliasedAssym' if the nonce precedes the key.
319getAssym :: Serialize a => Get (Assym a)
320getAssym = Assym <$> getPublicKey <*> get <*> get
321
322putAssym :: Serialize a => Assym a -> Put
323putAssym (Assym key nonce dta) = putPublicKey key >> put nonce >> put dta
324
325-- | Field order: nonce, and then senderKey.
326getAliasedAssym :: Serialize a => Get (Assym a)
327getAliasedAssym = flip Assym <$> get <*> getPublicKey <*> get
328
329putAliasedAssym :: Serialize a => Assym a -> Put
330putAliasedAssym (Assym key nonce dta) = put nonce >> putPublicKey key >> put dta
331
332newtype SymmetricKey = SymmetricKey ByteString
333
334data TransportCrypto = TransportCrypto
335 { transportSecret :: SecretKey
336 , transportPublic :: PublicKey
337 , transportSymmetric :: STM SymmetricKey
338 , transportNewNonce :: STM Nonce24
339 }
340
341getPublicKey :: S.Get PublicKey
342getPublicKey = throwCryptoError . publicKey <$> S.getBytes 32
343
344putPublicKey :: PublicKey -> S.Put
345putPublicKey bs = S.putByteString $ BA.convert bs
346