summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Crypto/Cipher/Salsa.hs83
-rw-r--r--src/Crypto/Cipher/XSalsa.hs50
-rw-r--r--src/Crypto/ECC/Class.hs127
-rw-r--r--src/Crypto/ECC/Simple/Prim.hs208
-rw-r--r--src/Crypto/ECC/Simple/Types.hs615
-rw-r--r--src/Crypto/Error/Types.hs106
-rw-r--r--src/Crypto/Internal/ByteArray.hs19
-rw-r--r--src/Crypto/Internal/Compat.hs48
-rw-r--r--src/Crypto/Internal/DeepSeq.hs33
-rw-r--r--src/Crypto/Internal/Imports.hs16
-rw-r--r--src/Crypto/PubKey/Curve25519.hs131
-rw-r--r--src/Network/BitTorrent/DHT.hs6
-rw-r--r--src/Network/BitTorrent/DHT/Query.hs103
-rw-r--r--src/Network/DHT.hs2
-rw-r--r--src/Network/DHT/Types.hs2
-rw-r--r--src/Network/DatagramServer.hs20
-rw-r--r--src/Network/DatagramServer/Mainline.hs23
-rw-r--r--src/Network/DatagramServer/Tox.hs118
-rw-r--r--src/Network/DatagramServer/Types.hs33
-rw-r--r--src/StaticAssert.hs13
20 files changed, 1704 insertions, 52 deletions
diff --git a/src/Crypto/Cipher/Salsa.hs b/src/Crypto/Cipher/Salsa.hs
new file mode 100644
index 00000000..b6b188b1
--- /dev/null
+++ b/src/Crypto/Cipher/Salsa.hs
@@ -0,0 +1,83 @@
1-- |
2-- Module : Crypto.Cipher.Salsa
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : stable
6-- Portability : good
7--
8{-# LANGUAGE ForeignFunctionInterface #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10module Crypto.Cipher.Salsa
11 ( initialize
12 , combine
13 , generate
14 , State(..)
15 ) where
16
17import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
18import qualified Crypto.Internal.ByteArray as B
19import Crypto.Internal.Compat
20import Crypto.Internal.Imports
21import Foreign.Ptr
22import Foreign.C.Types
23
24-- | Salsa context
25newtype State = State ScrubbedBytes
26 deriving (NFData)
27
28-- | Initialize a new Salsa context with the number of rounds,
29-- the key and the nonce associated.
30initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
31 => Int -- ^ number of rounds (8,12,20)
32 -> key -- ^ the key (128 or 256 bits)
33 -> nonce -- ^ the nonce (64 or 96 bits)
34 -> State -- ^ the initial Salsa state
35initialize nbRounds key nonce
36 | not (kLen `elem` [16,32]) = error "Salsa: key length should be 128 or 256 bits"
37 | not (nonceLen `elem` [8,12]) = error "Salsa: nonce length should be 64 or 96 bits"
38 | not (nbRounds `elem` [8,12,20]) = error "Salsa: rounds should be 8, 12 or 20"
39 | otherwise = unsafeDoIO $ do
40 stPtr <- B.alloc 132 $ \stPtr ->
41 B.withByteArray nonce $ \noncePtr ->
42 B.withByteArray key $ \keyPtr ->
43 ccryptonite_salsa_init stPtr (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
44 return $ State stPtr
45 where kLen = B.length key
46 nonceLen = B.length nonce
47
48-- | Combine the salsa output and an arbitrary message with a xor,
49-- and return the combined output and the new state.
50combine :: ByteArray ba
51 => State -- ^ the current Salsa state
52 -> ba -- ^ the source to xor with the generator
53 -> (ba, State)
54combine prevSt@(State prevStMem) src
55 | B.null src = (B.empty, prevSt)
56 | otherwise = unsafeDoIO $ do
57 (out, st) <- B.copyRet prevStMem $ \ctx ->
58 B.alloc (B.length src) $ \dstPtr ->
59 B.withByteArray src $ \srcPtr -> do
60 ccryptonite_salsa_combine dstPtr ctx srcPtr (fromIntegral $ B.length src)
61 return (out, State st)
62
63-- | Generate a number of bytes from the Salsa output directly
64generate :: ByteArray ba
65 => State -- ^ the current Salsa state
66 -> Int -- ^ the length of data to generate
67 -> (ba, State)
68generate prevSt@(State prevStMem) len
69 | len <= 0 = (B.empty, prevSt)
70 | otherwise = unsafeDoIO $ do
71 (out, st) <- B.copyRet prevStMem $ \ctx ->
72 B.alloc len $ \dstPtr ->
73 ccryptonite_salsa_generate dstPtr ctx (fromIntegral len)
74 return (out, State st)
75
76foreign import ccall "cryptonite_salsa_init"
77 ccryptonite_salsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
78
79foreign import ccall "cryptonite_salsa_combine"
80 ccryptonite_salsa_combine :: Ptr Word8 -> Ptr State -> Ptr Word8 -> CUInt -> IO ()
81
82foreign import ccall "cryptonite_salsa_generate"
83 ccryptonite_salsa_generate :: Ptr Word8 -> Ptr State -> CUInt -> IO ()
diff --git a/src/Crypto/Cipher/XSalsa.hs b/src/Crypto/Cipher/XSalsa.hs
new file mode 100644
index 00000000..494760e2
--- /dev/null
+++ b/src/Crypto/Cipher/XSalsa.hs
@@ -0,0 +1,50 @@
1-- |
2-- Module : Crypto.Cipher.XSalsa
3-- License : BSD-style
4-- Maintainer : Brandon Hamilton <brandon.hamilton@gmail.com>
5-- Stability : stable
6-- Portability : good
7--
8-- Implementation of XSalsa20 algorithm
9-- <https://cr.yp.to/snuffle/xsalsa-20081128.pdf>
10-- Based on the Salsa20 algorithm with 256 bit key extended with 192 bit nonce
11
12{-# LANGUAGE ForeignFunctionInterface #-}
13module Crypto.Cipher.XSalsa
14 ( initialize
15 , combine
16 , generate
17 , State
18 ) where
19
20import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
21import qualified Crypto.Internal.ByteArray as B
22import Crypto.Internal.Compat
23import Crypto.Internal.Imports
24import Foreign.Ptr
25import Foreign.Storable
26import Foreign.C.Types
27import Crypto.Cipher.Salsa hiding (initialize)
28
29-- | Initialize a new XSalsa context with the number of rounds,
30-- the key and the nonce associated.
31initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
32 => Int -- ^ number of rounds (8,12,20)
33 -> key -- ^ the key (256 bits)
34 -> nonce -- ^ the nonce (192 bits)
35 -> State -- ^ the initial XSalsa state
36initialize nbRounds key nonce
37 | kLen /= 32 = error "XSalsa: key length should be 256 bits"
38 | nonceLen /= 24 = error "XSalsa: nonce length should be 192 bits"
39 | not (nbRounds `elem` [8,12,20]) = error "XSalsa: rounds should be 8, 12 or 20"
40 | otherwise = unsafeDoIO $ do
41 stPtr <- B.alloc 132 $ \stPtr ->
42 B.withByteArray nonce $ \noncePtr ->
43 B.withByteArray key $ \keyPtr ->
44 ccryptonite_xsalsa_init stPtr (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
45 return $ State stPtr
46 where kLen = B.length key
47 nonceLen = B.length nonce
48
49foreign import ccall "cryptonite_xsalsa_init"
50 ccryptonite_xsalsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
diff --git a/src/Crypto/ECC/Class.hs b/src/Crypto/ECC/Class.hs
new file mode 100644
index 00000000..16b2cc15
--- /dev/null
+++ b/src/Crypto/ECC/Class.hs
@@ -0,0 +1,127 @@
1-- |
2-- Module : Crypto.ECC.Class
3-- License : BSD-style
4-- Stability : experimental
5-- Portability : unknown
6--
7-- Elliptic Curve Cryptography
8--
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12module Crypto.ECC.Class
13 ( Curve_X25519(..)
14 , EllipticCurve(..)
15 , EllipticCurveDH(..)
16 , EllipticCurveArith(..)
17 , KeyPair(..)
18 , SharedSecret(..)
19 ) where
20
21import qualified Crypto.ECC.Simple.Types as Simple
22import qualified Crypto.ECC.Simple.Prim as Simple
23import Crypto.Random
24-- import Crypto.Error
25import Crypto.Error.Types
26-- import Crypto.Internal.Proxy
27import Data.Typeable
28import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
29import qualified Crypto.Internal.ByteArray as B
30import Crypto.Number.Serialize (i2ospOf_, os2ip)
31import qualified Crypto.PubKey.Curve25519 as X25519
32import Data.ByteArray (convert)
33
34-- | An elliptic curve key pair composed of the private part (a scalar), and
35-- the associated point.
36data KeyPair curve = KeyPair
37 { keypairGetPublic :: !(Point curve)
38 , keypairGetPrivate :: !(Scalar curve)
39 }
40
41newtype SharedSecret = SharedSecret ScrubbedBytes
42 deriving (Eq, ByteArrayAccess)
43
44class EllipticCurve curve where
45 -- | Point on an Elliptic Curve
46 type Point curve :: *
47
48 -- | Scalar in the Elliptic Curve domain
49 type Scalar curve :: *
50
51 -- | Generate a new random scalar on the curve.
52 -- The scalar will represent a number between 1 and the order of the curve non included
53 curveGenerateScalar :: MonadRandom randomly => proxy curve -> randomly (Scalar curve)
54
55 -- | Generate a new random keypair
56 curveGenerateKeyPair :: MonadRandom randomly => proxy curve -> randomly (KeyPair curve)
57
58 -- | Get the curve size in bits
59 curveSizeBits :: proxy curve -> Int
60
61 -- | Encode a elliptic curve point into binary form
62 encodePoint :: ByteArray bs => proxy curve -> Point curve -> bs
63
64 -- | Try to decode the binary form of an elliptic curve point
65 decodePoint :: ByteArray bs => proxy curve -> bs -> CryptoFailable (Point curve)
66
67class EllipticCurve curve => EllipticCurveDH curve where
68 -- | Generate a Diffie hellman secret value.
69 --
70 -- This is generally just the .x coordinate of the resulting point, that
71 -- is not hashed.
72 --
73 -- use `pointSmul` to keep the result in Point format.
74 ecdh :: proxy curve -> Scalar curve -> Point curve -> SharedSecret
75
76class EllipticCurve curve => EllipticCurveArith curve where
77 -- | Add points on a curve
78 pointAdd :: proxy curve -> Point curve -> Point curve -> Point curve
79
80 -- | Scalar Multiplication on a curve
81 pointSmul :: proxy curve -> Scalar curve -> Point curve -> Point curve
82
83-- -- | Scalar Inverse
84-- scalarInverse :: Scalar curve -> Scalar curve
85
86data Curve_X25519 = Curve_X25519
87
88instance EllipticCurve Curve_X25519 where
89 type Point Curve_X25519 = X25519.PublicKey
90 type Scalar Curve_X25519 = X25519.SecretKey
91 curveSizeBits _ = 255
92 curveGenerateScalar _ = X25519.generateSecretKey
93 curveGenerateKeyPair _ = do
94 s <- X25519.generateSecretKey
95 return $ KeyPair (X25519.toPublic s) s
96 encodePoint _ p = B.convert p
97 decodePoint _ bs = X25519.publicKey bs
98
99instance EllipticCurveDH Curve_X25519 where
100 ecdh _ s p = SharedSecret $ convert secret
101 where secret = X25519.dh p s
102
103encodeECPoint :: forall curve bs . (Simple.Curve curve, ByteArray bs) => Simple.Point curve -> bs
104encodeECPoint Simple.PointO = error "encodeECPoint: cannot serialize point at infinity"
105encodeECPoint (Simple.Point x y) = B.concat [uncompressed,xb,yb]
106 where
107 size = Simple.curveSizeBytes (Proxy :: Proxy curve)
108 uncompressed, xb, yb :: bs
109 uncompressed = B.singleton 4
110 xb = i2ospOf_ size x
111 yb = i2ospOf_ size y
112
113decodeECPoint :: (Simple.Curve curve, ByteArray bs) => bs -> CryptoFailable (Simple.Point curve)
114decodeECPoint mxy = case B.uncons mxy of
115 Nothing -> CryptoFailed $ CryptoError_PointSizeInvalid
116 Just (m,xy)
117 -- uncompressed
118 | m == 4 ->
119 let siz = B.length xy `div` 2
120 (xb,yb) = B.splitAt siz xy
121 x = os2ip xb
122 y = os2ip yb
123 in Simple.pointFromIntegers (x,y)
124 | otherwise -> CryptoFailed $ CryptoError_PointFormatInvalid
125
126curveSizeBytes :: EllipticCurve c => Proxy c -> Int
127curveSizeBytes proxy = (curveSizeBits proxy + 7) `div` 8
diff --git a/src/Crypto/ECC/Simple/Prim.hs b/src/Crypto/ECC/Simple/Prim.hs
new file mode 100644
index 00000000..117988f2
--- /dev/null
+++ b/src/Crypto/ECC/Simple/Prim.hs
@@ -0,0 +1,208 @@
1-- | Elliptic Curve Arithmetic.
2--
3-- /WARNING:/ These functions are vulnerable to timing attacks.
4{-# LANGUAGE ScopedTypeVariables #-}
5module Crypto.ECC.Simple.Prim
6 ( scalarGenerate
7 , scalarFromInteger
8 , pointAdd
9 , pointDouble
10 , pointBaseMul
11 , pointMul
12 , pointAddTwoMuls
13 , pointFromIntegers
14 , isPointAtInfinity
15 , isPointValid
16 ) where
17
18import Data.Maybe
19import Data.Typeable
20import Crypto.Internal.Imports
21import Crypto.Number.ModArithmetic
22import Crypto.Number.F2m
23import Crypto.Number.Generate (generateBetween)
24import Crypto.ECC.Simple.Types
25-- import Crypto.Error
26import Crypto.Error.Types
27import Crypto.Random
28
29-- | Generate a valid scalar for a specific Curve
30scalarGenerate :: forall randomly curve . (MonadRandom randomly, Curve curve) => randomly (Scalar curve)
31scalarGenerate =
32 Scalar <$> generateBetween 1 (n - 1)
33 where
34 n = curveEccN $ curveParameters (Proxy :: Proxy curve)
35
36scalarFromInteger :: forall curve . Curve curve => Integer -> CryptoFailable (Scalar curve)
37scalarFromInteger n
38 | n < 0 || n >= mx = CryptoFailed $ CryptoError_EcScalarOutOfBounds
39 | otherwise = CryptoPassed $ Scalar n
40 where
41 mx = case curveType (Proxy :: Proxy curve) of
42 CurveBinary (CurveBinaryParam b) -> b
43 CurvePrime (CurvePrimeParam p) -> p
44
45--TODO: Extract helper function for `fromMaybe PointO...`
46
47-- | Elliptic Curve point negation:
48-- @pointNegate p@ returns point @q@ such that @pointAdd p q == PointO@.
49pointNegate :: Curve curve => Point curve -> Point curve
50pointNegate PointO = PointO
51pointNegate point@(Point x y) =
52 case curveType point of
53 CurvePrime {} -> Point x (-y)
54 CurveBinary {} -> Point x (x `addF2m` y)
55
56-- | Elliptic Curve point addition.
57--
58-- /WARNING:/ Vulnerable to timing attacks.
59pointAdd :: Curve curve => Point curve -> Point curve -> Point curve
60pointAdd PointO PointO = PointO
61pointAdd PointO q = q
62pointAdd p PointO = p
63pointAdd p q
64 | p == q = pointDouble p
65 | p == pointNegate q = PointO
66pointAdd point@(Point xp yp) (Point xq yq) =
67 case ty of
68 CurvePrime (CurvePrimeParam pr) -> fromMaybe PointO $ do
69 s <- divmod (yp - yq) (xp - xq) pr
70 let xr = (s ^ (2::Int) - xp - xq) `mod` pr
71 yr = (s * (xp - xr) - yp) `mod` pr
72 return $ Point xr yr
73 CurveBinary (CurveBinaryParam fx) -> fromMaybe PointO $ do
74 s <- divF2m fx (yp `addF2m` yq) (xp `addF2m` xq)
75 let xr = mulF2m fx s s `addF2m` s `addF2m` xp `addF2m` xq `addF2m` a
76 yr = mulF2m fx s (xp `addF2m` xr) `addF2m` xr `addF2m` yp
77 return $ Point xr yr
78 where
79 ty = curveType point
80 cc = curveParameters point
81 a = curveEccA cc
82
83-- | Elliptic Curve point doubling.
84--
85-- /WARNING:/ Vulnerable to timing attacks.
86--
87-- This perform the following calculation:
88-- > lambda = (3 * xp ^ 2 + a) / 2 yp
89-- > xr = lambda ^ 2 - 2 xp
90-- > yr = lambda (xp - xr) - yp
91--
92-- With binary curve:
93-- > xp == 0 => P = O
94-- > otherwise =>
95-- > s = xp + (yp / xp)
96-- > xr = s ^ 2 + s + a
97-- > yr = xp ^ 2 + (s+1) * xr
98--
99pointDouble :: Curve curve => Point curve -> Point curve
100pointDouble PointO = PointO
101pointDouble point@(Point xp yp) =
102 case ty of
103 CurvePrime (CurvePrimeParam pr) -> fromMaybe PointO $ do
104 lambda <- divmod (3 * xp ^ (2::Int) + a) (2 * yp) pr
105 let xr = (lambda ^ (2::Int) - 2 * xp) `mod` pr
106 yr = (lambda * (xp - xr) - yp) `mod` pr
107 return $ Point xr yr
108 CurveBinary (CurveBinaryParam fx)
109 | xp == 0 -> PointO
110 | otherwise -> fromMaybe PointO $ do
111 s <- return . addF2m xp =<< divF2m fx yp xp
112 let xr = mulF2m fx s s `addF2m` s `addF2m` a
113 yr = mulF2m fx xp xp `addF2m` mulF2m fx xr (s `addF2m` 1)
114 return $ Point xr yr
115 where
116 ty = curveType point
117 cc = curveParameters point
118 a = curveEccA cc
119
120-- | Elliptic curve point multiplication using the base
121--
122-- /WARNING:/ Vulnerable to timing attacks.
123pointBaseMul :: Curve curve => Scalar curve -> Point curve
124pointBaseMul n = pointMul n (curveEccG $ curveParameters (Proxy :: Proxy curve))
125
126-- | Elliptic curve point multiplication (double and add algorithm).
127--
128-- /WARNING:/ Vulnerable to timing attacks.
129pointMul :: Curve curve => Scalar curve -> Point curve -> Point curve
130pointMul _ PointO = PointO
131pointMul (Scalar n) p
132 | n == 0 = PointO
133 | n == 1 = p
134 | odd n = pointAdd p (pointMul (Scalar (n - 1)) p)
135 | otherwise = pointMul (Scalar (n `div` 2)) (pointDouble p)
136
137-- | Elliptic curve double-scalar multiplication (uses Shamir's trick).
138--
139-- > pointAddTwoMuls n1 p1 n2 p2 == pointAdd (pointMul n1 p1)
140-- > (pointMul n2 p2)
141--
142-- /WARNING:/ Vulnerable to timing attacks.
143pointAddTwoMuls :: Curve curve => Scalar curve -> Point curve -> Scalar curve -> Point curve -> Point curve
144pointAddTwoMuls _ PointO _ PointO = PointO
145pointAddTwoMuls _ PointO n2 p2 = pointMul n2 p2
146pointAddTwoMuls n1 p1 _ PointO = pointMul n1 p1
147pointAddTwoMuls (Scalar n1) p1 (Scalar n2) p2 = go (n1, n2)
148 where
149 p0 = pointAdd p1 p2
150
151 go (0, 0 ) = PointO
152 go (k1, k2) =
153 let q = pointDouble $ go (k1 `div` 2, k2 `div` 2)
154 in case (odd k1, odd k2) of
155 (True , True ) -> pointAdd p0 q
156 (True , False ) -> pointAdd p1 q
157 (False , True ) -> pointAdd p2 q
158 (False , False ) -> q
159
160-- | Check if a point is the point at infinity.
161isPointAtInfinity :: Point curve -> Bool
162isPointAtInfinity PointO = True
163isPointAtInfinity _ = False
164
165-- | Make a point on a curve from integer (x,y) coordinate
166--
167-- if the point is not valid related to the curve then an error is
168-- returned instead of a point
169pointFromIntegers :: forall curve . Curve curve => (Integer, Integer) -> CryptoFailable (Point curve)
170pointFromIntegers (x,y)
171 | isPointValid (Proxy :: Proxy curve) x y = CryptoPassed $ Point x y
172 | otherwise = CryptoFailed $ CryptoError_PointCoordinatesInvalid
173
174-- | check if a point is on specific curve
175--
176-- This perform three checks:
177--
178-- * x is not out of range
179-- * y is not out of range
180-- * the equation @y^2 = x^3 + a*x + b (mod p)@ holds
181isPointValid :: Curve curve => proxy curve -> Integer -> Integer -> Bool
182isPointValid proxy x y =
183 case ty of
184 CurvePrime (CurvePrimeParam p) ->
185 let a = curveEccA cc
186 b = curveEccB cc
187 eqModP z1 z2 = (z1 `mod` p) == (z2 `mod` p)
188 isValid e = e >= 0 && e < p
189 in isValid x && isValid y && (y ^ (2 :: Int)) `eqModP` (x ^ (3 :: Int) + a * x + b)
190 CurveBinary (CurveBinaryParam fx) ->
191 let a = curveEccA cc
192 b = curveEccB cc
193 add = addF2m
194 mul = mulF2m fx
195 isValid e = modF2m fx e == e
196 in and [ isValid x
197 , isValid y
198 , ((((x `add` a) `mul` x `add` y) `mul` x) `add` b `add` (squareF2m fx y)) == 0
199 ]
200 where
201 ty = curveType proxy
202 cc = curveParameters proxy
203
204-- | div and mod
205divmod :: Integer -> Integer -> Integer -> Maybe Integer
206divmod y x m = do
207 i <- inverse (x `mod` m) m
208 return $ y * i `mod` m
diff --git a/src/Crypto/ECC/Simple/Types.hs b/src/Crypto/ECC/Simple/Types.hs
new file mode 100644
index 00000000..c97daa29
--- /dev/null
+++ b/src/Crypto/ECC/Simple/Types.hs
@@ -0,0 +1,615 @@
1{-# LANGUAGE DeriveDataTypeable #-}
2-- |
3-- Module : Crypto.ECC.Simple.Types
4-- License : BSD-style
5-- Maintainer : Vincent Hanquez <vincent@snarc.org>
6-- Stability : Experimental
7-- Portability : Excellent
8--
9-- references:
10-- <https://tools.ietf.org/html/rfc5915>
11--
12{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
13module Crypto.ECC.Simple.Types
14 ( Curve(..)
15 , Point(..)
16 , Scalar(..)
17 , CurveType(..)
18 , CurveBinaryParam(..)
19 , CurvePrimeParam(..)
20 , curveSizeBits
21 , curveSizeBytes
22 , CurveParameters(..)
23 -- * specific curves definition
24 , SEC_p112r1(..)
25 , SEC_p112r2(..)
26 , SEC_p128r1(..)
27 , SEC_p128r2(..)
28 , SEC_p160k1(..)
29 , SEC_p160r1(..)
30 , SEC_p160r2(..)
31 , SEC_p192k1(..)
32 , SEC_p192r1(..) -- aka prime192v1
33 , SEC_p224k1(..)
34 , SEC_p224r1(..)
35 , SEC_p256k1(..)
36 , SEC_p256r1(..) -- aka prime256v1
37 , SEC_p384r1(..)
38 , SEC_p521r1(..)
39 , SEC_t113r1(..)
40 , SEC_t113r2(..)
41 , SEC_t131r1(..)
42 , SEC_t131r2(..)
43 , SEC_t163k1(..)
44 , SEC_t163r1(..)
45 , SEC_t163r2(..)
46 , SEC_t193r1(..)
47 , SEC_t193r2(..)
48 , SEC_t233k1(..) -- aka NIST K-233
49 , SEC_t233r1(..)
50 , SEC_t239k1(..)
51 , SEC_t283k1(..)
52 , SEC_t283r1(..)
53 , SEC_t409k1(..)
54 , SEC_t409r1(..)
55 , SEC_t571k1(..)
56 , SEC_t571r1(..)
57 ) where
58
59import Data.Data
60import Crypto.Internal.Imports
61import Crypto.Number.Basic (numBits)
62
63class Curve curve where
64 curveParameters :: proxy curve -> CurveParameters curve
65 curveType :: proxy curve -> CurveType
66
67-- | get the size of the curve in bits
68curveSizeBits :: Curve curve => proxy curve -> Int
69curveSizeBits proxy =
70 case curveType proxy of
71 CurvePrime (CurvePrimeParam p) -> numBits p
72 CurveBinary (CurveBinaryParam c) -> numBits c - 1
73
74-- | get the size of the curve in bytes
75curveSizeBytes :: Curve curve => proxy curve -> Int
76curveSizeBytes proxy = (curveSizeBits proxy + 7) `div` 8
77
78-- | Define common parameters in a curve definition
79-- of the form: y^2 = x^3 + ax + b.
80data CurveParameters curve = CurveParameters
81 { curveEccA :: Integer -- ^ curve parameter a
82 , curveEccB :: Integer -- ^ curve parameter b
83 , curveEccG :: Point curve -- ^ base point
84 , curveEccN :: Integer -- ^ order of G
85 , curveEccH :: Integer -- ^ cofactor
86 } deriving (Show,Eq,Data,Typeable)
87
88newtype CurveBinaryParam = CurveBinaryParam Integer
89 deriving (Show,Read,Eq,Data,Typeable)
90
91newtype CurvePrimeParam = CurvePrimeParam Integer
92 deriving (Show,Read,Eq,Data,Typeable)
93
94data CurveType =
95 CurveBinary CurveBinaryParam
96 | CurvePrime CurvePrimeParam
97 deriving (Show,Read,Eq,Data,Typeable)
98
99-- | ECC Private Number
100newtype Scalar curve = Scalar Integer
101 deriving (Show,Read,Eq,Data,Typeable)
102
103-- | Define a point on a curve.
104data Point curve =
105 Point Integer Integer
106 | PointO -- ^ Point at Infinity
107 deriving (Show,Read,Eq,Data,Typeable)
108
109instance NFData (Point curve) where
110 rnf (Point x y) = x `seq` y `seq` ()
111 rnf PointO = ()
112
113data SEC_p112r1 = SEC_p112r1 deriving (Show,Read,Eq)
114data SEC_p112r2 = SEC_p112r2 deriving (Show,Read,Eq)
115data SEC_p128r1 = SEC_p128r1 deriving (Show,Read,Eq)
116data SEC_p128r2 = SEC_p128r2 deriving (Show,Read,Eq)
117data SEC_p160k1 = SEC_p160k1 deriving (Show,Read,Eq)
118data SEC_p160r1 = SEC_p160r1 deriving (Show,Read,Eq)
119data SEC_p160r2 = SEC_p160r2 deriving (Show,Read,Eq)
120data SEC_p192k1 = SEC_p192k1 deriving (Show,Read,Eq)
121data SEC_p192r1 = SEC_p192r1 deriving (Show,Read,Eq)
122data SEC_p224k1 = SEC_p224k1 deriving (Show,Read,Eq)
123data SEC_p224r1 = SEC_p224r1 deriving (Show,Read,Eq)
124data SEC_p256k1 = SEC_p256k1 deriving (Show,Read,Eq)
125data SEC_p256r1 = SEC_p256r1 deriving (Show,Read,Eq)
126data SEC_p384r1 = SEC_p384r1 deriving (Show,Read,Eq)
127data SEC_p521r1 = SEC_p521r1 deriving (Show,Read,Eq)
128data SEC_t113r1 = SEC_t113r1 deriving (Show,Read,Eq)
129data SEC_t113r2 = SEC_t113r2 deriving (Show,Read,Eq)
130data SEC_t131r1 = SEC_t131r1 deriving (Show,Read,Eq)
131data SEC_t131r2 = SEC_t131r2 deriving (Show,Read,Eq)
132data SEC_t163k1 = SEC_t163k1 deriving (Show,Read,Eq)
133data SEC_t163r1 = SEC_t163r1 deriving (Show,Read,Eq)
134data SEC_t163r2 = SEC_t163r2 deriving (Show,Read,Eq)
135data SEC_t193r1 = SEC_t193r1 deriving (Show,Read,Eq)
136data SEC_t193r2 = SEC_t193r2 deriving (Show,Read,Eq)
137data SEC_t233k1 = SEC_t233k1 deriving (Show,Read,Eq)
138data SEC_t233r1 = SEC_t233r1 deriving (Show,Read,Eq)
139data SEC_t239k1 = SEC_t239k1 deriving (Show,Read,Eq)
140data SEC_t283k1 = SEC_t283k1 deriving (Show,Read,Eq)
141data SEC_t283r1 = SEC_t283r1 deriving (Show,Read,Eq)
142data SEC_t409k1 = SEC_t409k1 deriving (Show,Read,Eq)
143data SEC_t409r1 = SEC_t409r1 deriving (Show,Read,Eq)
144data SEC_t571k1 = SEC_t571k1 deriving (Show,Read,Eq)
145data SEC_t571r1 = SEC_t571r1 deriving (Show,Read,Eq)
146
147-- | Define names for known recommended curves.
148instance Curve SEC_p112r1 where
149 curveType _ = typeSEC_p112r1
150 curveParameters _ = paramSEC_p112r1
151
152instance Curve SEC_p112r2 where
153 curveType _ = typeSEC_p112r2
154 curveParameters _ = paramSEC_p112r2
155
156instance Curve SEC_p128r1 where
157 curveType _ = typeSEC_p128r1
158 curveParameters _ = paramSEC_p128r1
159
160instance Curve SEC_p128r2 where
161 curveType _ = typeSEC_p128r2
162 curveParameters _ = paramSEC_p128r2
163
164instance Curve SEC_p160k1 where
165 curveType _ = typeSEC_p160k1
166 curveParameters _ = paramSEC_p160k1
167
168instance Curve SEC_p160r1 where
169 curveType _ = typeSEC_p160r1
170 curveParameters _ = paramSEC_p160r1
171
172instance Curve SEC_p160r2 where
173 curveType _ = typeSEC_p160r2
174 curveParameters _ = paramSEC_p160r2
175
176instance Curve SEC_p192k1 where
177 curveType _ = typeSEC_p192k1
178 curveParameters _ = paramSEC_p192k1
179
180instance Curve SEC_p192r1 where
181 curveType _ = typeSEC_p192r1
182 curveParameters _ = paramSEC_p192r1
183
184instance Curve SEC_p224k1 where
185 curveType _ = typeSEC_p224k1
186 curveParameters _ = paramSEC_p224k1
187
188instance Curve SEC_p224r1 where
189 curveType _ = typeSEC_p224r1
190 curveParameters _ = paramSEC_p224r1
191
192instance Curve SEC_p256k1 where
193 curveType _ = typeSEC_p256k1
194 curveParameters _ = paramSEC_p256k1
195
196instance Curve SEC_p256r1 where
197 curveType _ = typeSEC_p256r1
198 curveParameters _ = paramSEC_p256r1
199
200instance Curve SEC_p384r1 where
201 curveType _ = typeSEC_p384r1
202 curveParameters _ = paramSEC_p384r1
203
204instance Curve SEC_p521r1 where
205 curveType _ = typeSEC_p521r1
206 curveParameters _ = paramSEC_p521r1
207
208instance Curve SEC_t113r1 where
209 curveType _ = typeSEC_t113r1
210 curveParameters _ = paramSEC_t113r1
211
212instance Curve SEC_t113r2 where
213 curveType _ = typeSEC_t113r2
214 curveParameters _ = paramSEC_t113r2
215
216instance Curve SEC_t131r1 where
217 curveType _ = typeSEC_t131r1
218 curveParameters _ = paramSEC_t131r1
219
220instance Curve SEC_t131r2 where
221 curveType _ = typeSEC_t131r2
222 curveParameters _ = paramSEC_t131r2
223
224instance Curve SEC_t163k1 where
225 curveType _ = typeSEC_t163k1
226 curveParameters _ = paramSEC_t163k1
227
228instance Curve SEC_t163r1 where
229 curveType _ = typeSEC_t163r1
230 curveParameters _ = paramSEC_t163r1
231
232instance Curve SEC_t163r2 where
233 curveType _ = typeSEC_t163r2
234 curveParameters _ = paramSEC_t163r2
235
236instance Curve SEC_t193r1 where
237 curveType _ = typeSEC_t193r1
238 curveParameters _ = paramSEC_t193r1
239
240instance Curve SEC_t193r2 where
241 curveType _ = typeSEC_t193r2
242 curveParameters _ = paramSEC_t193r2
243
244instance Curve SEC_t233k1 where
245 curveType _ = typeSEC_t233k1
246 curveParameters _ = paramSEC_t233k1
247
248instance Curve SEC_t233r1 where
249 curveType _ = typeSEC_t233r1
250 curveParameters _ = paramSEC_t233r1
251
252instance Curve SEC_t239k1 where
253 curveType _ = typeSEC_t239k1
254 curveParameters _ = paramSEC_t239k1
255
256instance Curve SEC_t283k1 where
257 curveType _ = typeSEC_t283k1
258 curveParameters _ = paramSEC_t283k1
259
260instance Curve SEC_t283r1 where
261 curveType _ = typeSEC_t283r1
262 curveParameters _ = paramSEC_t283r1
263
264instance Curve SEC_t409k1 where
265 curveType _ = typeSEC_t409k1
266 curveParameters _ = paramSEC_t409k1
267
268instance Curve SEC_t409r1 where
269 curveType _ = typeSEC_t409r1
270 curveParameters _ = paramSEC_t409r1
271
272instance Curve SEC_t571k1 where
273 curveType _ = typeSEC_t571k1
274 curveParameters _ = paramSEC_t571k1
275
276instance Curve SEC_t571r1 where
277 curveType _ = typeSEC_t571r1
278 curveParameters _ = paramSEC_t571r1
279
280{-
281curvesOIDs :: [ (CurveName, [Integer]) ]
282curvesOIDs =
283 [ (SEC_p112r1, [1,3,132,0,6])
284 , (SEC_p112r2, [1,3,132,0,7])
285 , (SEC_p128r1, [1,3,132,0,28])
286 , (SEC_p128r2, [1,3,132,0,29])
287 , (SEC_p160k1, [1,3,132,0,9])
288 , (SEC_p160r1, [1,3,132,0,8])
289 , (SEC_p160r2, [1,3,132,0,30])
290 , (SEC_p192k1, [1,3,132,0,31])
291 , (SEC_p192r1, [1,2,840,10045,3,1,1])
292 , (SEC_p224k1, [1,3,132,0,32])
293 , (SEC_p224r1, [1,3,132,0,33])
294 , (SEC_p256k1, [1,3,132,0,10])
295 , (SEC_p256r1, [1,2,840,10045,3,1,7])
296 , (SEC_p384r1, [1,3,132,0,34])
297 , (SEC_p521r1, [1,3,132,0,35])
298 , (SEC_t113r1, [1,3,132,0,4])
299 , (SEC_t113r2, [1,3,132,0,5])
300 , (SEC_t131r1, [1,3,132,0,22])
301 , (SEC_t131r2, [1,3,132,0,23])
302 , (SEC_t163k1, [1,3,132,0,1])
303 , (SEC_t163r1, [1,3,132,0,2])
304 , (SEC_t163r2, [1,3,132,0,15])
305 , (SEC_t193r1, [1,3,132,0,24])
306 , (SEC_t193r2, [1,3,132,0,25])
307 , (SEC_t233k1, [1,3,132,0,26])
308 , (SEC_t233r1, [1,3,132,0,27])
309 , (SEC_t239k1, [1,3,132,0,3])
310 , (SEC_t283k1, [1,3,132,0,16])
311 , (SEC_t283r1, [1,3,132,0,17])
312 , (SEC_t409k1, [1,3,132,0,36])
313 , (SEC_t409r1, [1,3,132,0,37])
314 , (SEC_t571k1, [1,3,132,0,38])
315 , (SEC_t571r1, [1,3,132,0,39])
316 ]
317-}
318
319typeSEC_p112r1 = CurvePrime $ CurvePrimeParam 0xdb7c2abf62e35e668076bead208b
320paramSEC_p112r1 = CurveParameters
321 { curveEccA = 0xdb7c2abf62e35e668076bead2088
322 , curveEccB = 0x659ef8ba043916eede8911702b22
323 , curveEccG = Point 0x09487239995a5ee76b55f9c2f098
324 0xa89ce5af8724c0a23e0e0ff77500
325 , curveEccN = 0xdb7c2abf62e35e7628dfac6561c5
326 , curveEccH = 1
327 }
328typeSEC_p112r2 = CurvePrime $ CurvePrimeParam 0xdb7c2abf62e35e668076bead208b
329paramSEC_p112r2 = CurveParameters
330 { curveEccA = 0x6127c24c05f38a0aaaf65c0ef02c
331 , curveEccB = 0x51def1815db5ed74fcc34c85d709
332 , curveEccG = Point 0x4ba30ab5e892b4e1649dd0928643
333 0xadcd46f5882e3747def36e956e97
334 , curveEccN = 0x36df0aafd8b8d7597ca10520d04b
335 , curveEccH = 4
336 }
337typeSEC_p128r1 = CurvePrime $ CurvePrimeParam 0xfffffffdffffffffffffffffffffffff
338paramSEC_p128r1 = CurveParameters
339 { curveEccA = 0xfffffffdfffffffffffffffffffffffc
340 , curveEccB = 0xe87579c11079f43dd824993c2cee5ed3
341 , curveEccG = Point 0x161ff7528b899b2d0c28607ca52c5b86
342 0xcf5ac8395bafeb13c02da292dded7a83
343 , curveEccN = 0xfffffffe0000000075a30d1b9038a115
344 , curveEccH = 1
345 }
346typeSEC_p128r2 = CurvePrime $ CurvePrimeParam 0xfffffffdffffffffffffffffffffffff
347paramSEC_p128r2 = CurveParameters
348 { curveEccA = 0xd6031998d1b3bbfebf59cc9bbff9aee1
349 , curveEccB = 0x5eeefca380d02919dc2c6558bb6d8a5d
350 , curveEccG = Point 0x7b6aa5d85e572983e6fb32a7cdebc140
351 0x27b6916a894d3aee7106fe805fc34b44
352 , curveEccN = 0x3fffffff7fffffffbe0024720613b5a3
353 , curveEccH = 4
354 }
355typeSEC_p160k1 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffeffffac73
356paramSEC_p160k1 = CurveParameters
357 { curveEccA = 0x000000000000000000000000000000000000000000
358 , curveEccB = 0x000000000000000000000000000000000000000007
359 , curveEccG = Point 0x003b4c382ce37aa192a4019e763036f4f5dd4d7ebb
360 0x00938cf935318fdced6bc28286531733c3f03c4fee
361 , curveEccN = 0x0100000000000000000001b8fa16dfab9aca16b6b3
362 , curveEccH = 1
363 }
364typeSEC_p160r1 = CurvePrime $ CurvePrimeParam 0x00ffffffffffffffffffffffffffffffff7fffffff
365paramSEC_p160r1 = CurveParameters
366 { curveEccA = 0x00ffffffffffffffffffffffffffffffff7ffffffc
367 , curveEccB = 0x001c97befc54bd7a8b65acf89f81d4d4adc565fa45
368 , curveEccG = Point 0x004a96b5688ef573284664698968c38bb913cbfc82
369 0x0023a628553168947d59dcc912042351377ac5fb32
370 , curveEccN = 0x0100000000000000000001f4c8f927aed3ca752257
371 , curveEccH = 1
372 }
373typeSEC_p160r2 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffeffffac73
374paramSEC_p160r2 = CurveParameters
375 { curveEccA = 0x00fffffffffffffffffffffffffffffffeffffac70
376 , curveEccB = 0x00b4e134d3fb59eb8bab57274904664d5af50388ba
377 , curveEccG = Point 0x0052dcb034293a117e1f4ff11b30f7199d3144ce6d
378 0x00feaffef2e331f296e071fa0df9982cfea7d43f2e
379 , curveEccN = 0x0100000000000000000000351ee786a818f3a1a16b
380 , curveEccH = 1
381 }
382typeSEC_p192k1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffeffffee37
383paramSEC_p192k1 = CurveParameters
384 { curveEccA = 0x000000000000000000000000000000000000000000000000
385 , curveEccB = 0x000000000000000000000000000000000000000000000003
386 , curveEccG = Point 0xdb4ff10ec057e9ae26b07d0280b7f4341da5d1b1eae06c7d
387 0x9b2f2f6d9c5628a7844163d015be86344082aa88d95e2f9d
388 , curveEccN = 0xfffffffffffffffffffffffe26f2fc170f69466a74defd8d
389 , curveEccH = 1
390 }
391typeSEC_p192r1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffeffffffffffffffff
392paramSEC_p192r1 = CurveParameters
393 { curveEccA = 0xfffffffffffffffffffffffffffffffefffffffffffffffc
394 , curveEccB = 0x64210519e59c80e70fa7e9ab72243049feb8deecc146b9b1
395 , curveEccG = Point 0x188da80eb03090f67cbf20eb43a18800f4ff0afd82ff1012
396 0x07192b95ffc8da78631011ed6b24cdd573f977a11e794811
397 , curveEccN = 0xffffffffffffffffffffffff99def836146bc9b1b4d22831
398 , curveEccH = 1
399 }
400typeSEC_p224k1 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffffffffffffffffffeffffe56d
401paramSEC_p224k1 = CurveParameters
402 { curveEccA = 0x0000000000000000000000000000000000000000000000000000000000
403 , curveEccB = 0x0000000000000000000000000000000000000000000000000000000005
404 , curveEccG = Point 0x00a1455b334df099df30fc28a169a467e9e47075a90f7e650eb6b7a45c
405 0x007e089fed7fba344282cafbd6f7e319f7c0b0bd59e2ca4bdb556d61a5
406 , curveEccN = 0x010000000000000000000000000001dce8d2ec6184caf0a971769fb1f7
407 , curveEccH = 1
408 }
409typeSEC_p224r1 = CurvePrime $ CurvePrimeParam 0xffffffffffffffffffffffffffffffff000000000000000000000001
410paramSEC_p224r1 = CurveParameters
411 { curveEccA = 0xfffffffffffffffffffffffffffffffefffffffffffffffffffffffe
412 , curveEccB = 0xb4050a850c04b3abf54132565044b0b7d7bfd8ba270b39432355ffb4
413 , curveEccG = Point 0xb70e0cbd6bb4bf7f321390b94a03c1d356c21122343280d6115c1d21
414 0xbd376388b5f723fb4c22dfe6cd4375a05a07476444d5819985007e34
415 , curveEccN = 0xffffffffffffffffffffffffffff16a2e0b8f03e13dd29455c5c2a3d
416 , curveEccH = 1
417 }
418typeSEC_p256k1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f
419paramSEC_p256k1 = CurveParameters
420 { curveEccA = 0x0000000000000000000000000000000000000000000000000000000000000000
421 , curveEccB = 0x0000000000000000000000000000000000000000000000000000000000000007
422 , curveEccG = Point 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798
423 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8
424 , curveEccN = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141
425 , curveEccH = 1
426 }
427typeSEC_p256r1 = CurvePrime $ CurvePrimeParam 0xffffffff00000001000000000000000000000000ffffffffffffffffffffffff
428paramSEC_p256r1 = CurveParameters
429 { curveEccA = 0xffffffff00000001000000000000000000000000fffffffffffffffffffffffc
430 , curveEccB = 0x5ac635d8aa3a93e7b3ebbd55769886bc651d06b0cc53b0f63bce3c3e27d2604b
431 , curveEccG = Point 0x6b17d1f2e12c4247f8bce6e563a440f277037d812deb33a0f4a13945d898c296
432 0x4fe342e2fe1a7f9b8ee7eb4a7c0f9e162bce33576b315ececbb6406837bf51f5
433 , curveEccN = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551
434 , curveEccH = 1
435 }
436typeSEC_p384r1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000ffffffff
437paramSEC_p384r1 = CurveParameters
438 { curveEccA = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000fffffffc
439 , curveEccB = 0xb3312fa7e23ee7e4988e056be3f82d19181d9c6efe8141120314088f5013875ac656398d8a2ed19d2a85c8edd3ec2aef
440 , curveEccG = Point 0xaa87ca22be8b05378eb1c71ef320ad746e1d3b628ba79b9859f741e082542a385502f25dbf55296c3a545e3872760ab7
441 0x3617de4a96262c6f5d9e98bf9292dc29f8f41dbd289a147ce9da3113b5f0b8c00a60b1ce1d7e819d7a431d7c90ea0e5f
442 , curveEccN = 0xffffffffffffffffffffffffffffffffffffffffffffffffc7634d81f4372ddf581a0db248b0a77aecec196accc52973
443 , curveEccH = 1
444 }
445typeSEC_p521r1 = CurvePrime $ CurvePrimeParam 0x01ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
446paramSEC_p521r1 = CurveParameters
447 { curveEccA = 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc
448 , curveEccB = 0x0051953eb9618e1c9a1f929a21a0b68540eea2da725b99b315f3b8b489918ef109e156193951ec7e937b1652c0bd3bb1bf073573df883d2c34f1ef451fd46b503f00
449 , curveEccG = Point 0x00c6858e06b70404e9cd9e3ecb662395b4429c648139053fb521f828af606b4d3dbaa14b5e77efe75928fe1dc127a2ffa8de3348b3c1856a429bf97e7e31c2e5bd66
450 0x011839296a789a3bc0045c8a5fb42c7d1bd998f54449579b446817afbd17273e662c97ee72995ef42640c550b9013fad0761353c7086a272c24088be94769fd16650
451 , curveEccN = 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa51868783bf2f966b7fcc0148f709a5d03bb5c9b8899c47aebb6fb71e91386409
452 , curveEccH = 1
453 }
454typeSEC_t113r1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000201
455paramSEC_t113r1 = CurveParameters
456 { curveEccA = 0x003088250ca6e7c7fe649ce85820f7
457 , curveEccB = 0x00e8bee4d3e2260744188be0e9c723
458 , curveEccG = Point 0x009d73616f35f4ab1407d73562c10f
459 0x00a52830277958ee84d1315ed31886
460 , curveEccN = 0x0100000000000000d9ccec8a39e56f
461 , curveEccH = 2
462 }
463typeSEC_t113r2 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000201
464paramSEC_t113r2 = CurveParameters
465 { curveEccA = 0x00689918dbec7e5a0dd6dfc0aa55c7
466 , curveEccB = 0x0095e9a9ec9b297bd4bf36e059184f
467 , curveEccG = Point 0x01a57a6a7b26ca5ef52fcdb8164797
468 0x00b3adc94ed1fe674c06e695baba1d
469 , curveEccN = 0x010000000000000108789b2496af93
470 , curveEccH = 2
471 }
472typeSEC_t131r1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000010d
473paramSEC_t131r1 = CurveParameters
474 { curveEccA = 0x07a11b09a76b562144418ff3ff8c2570b8
475 , curveEccB = 0x0217c05610884b63b9c6c7291678f9d341
476 , curveEccG = Point 0x0081baf91fdf9833c40f9c181343638399
477 0x078c6e7ea38c001f73c8134b1b4ef9e150
478 , curveEccN = 0x0400000000000000023123953a9464b54d
479 , curveEccH = 2
480 }
481typeSEC_t131r2 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000010d
482paramSEC_t131r2 = CurveParameters
483 { curveEccA = 0x03e5a88919d7cafcbf415f07c2176573b2
484 , curveEccB = 0x04b8266a46c55657ac734ce38f018f2192
485 , curveEccG = Point 0x0356dcd8f2f95031ad652d23951bb366a8
486 0x0648f06d867940a5366d9e265de9eb240f
487 , curveEccN = 0x0400000000000000016954a233049ba98f
488 , curveEccH = 2
489 }
490typeSEC_t163k1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
491paramSEC_t163k1 = CurveParameters
492 { curveEccA = 0x000000000000000000000000000000000000000001
493 , curveEccB = 0x000000000000000000000000000000000000000001
494 , curveEccG = Point 0x02fe13c0537bbc11acaa07d793de4e6d5e5c94eee8
495 0x0289070fb05d38ff58321f2e800536d538ccdaa3d9
496 , curveEccN = 0x04000000000000000000020108a2e0cc0d99f8a5ef
497 , curveEccH = 2
498 }
499typeSEC_t163r1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
500paramSEC_t163r1 = CurveParameters
501 { curveEccA = 0x07b6882caaefa84f9554ff8428bd88e246d2782ae2
502 , curveEccB = 0x0713612dcddcb40aab946bda29ca91f73af958afd9
503 , curveEccG = Point 0x0369979697ab43897789566789567f787a7876a654
504 0x00435edb42efafb2989d51fefce3c80988f41ff883
505 , curveEccN = 0x03ffffffffffffffffffff48aab689c29ca710279b
506 , curveEccH = 2
507 }
508typeSEC_t163r2 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
509paramSEC_t163r2 = CurveParameters
510 { curveEccA = 0x000000000000000000000000000000000000000001
511 , curveEccB = 0x020a601907b8c953ca1481eb10512f78744a3205fd
512 , curveEccG = Point 0x03f0eba16286a2d57ea0991168d4994637e8343e36
513 0x00d51fbc6c71a0094fa2cdd545b11c5c0c797324f1
514 , curveEccN = 0x040000000000000000000292fe77e70c12a4234c33
515 , curveEccH = 2
516 }
517typeSEC_t193r1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000008001
518paramSEC_t193r1 = CurveParameters
519 { curveEccA = 0x0017858feb7a98975169e171f77b4087de098ac8a911df7b01
520 , curveEccB = 0x00fdfb49bfe6c3a89facadaa7a1e5bbc7cc1c2e5d831478814
521 , curveEccG = Point 0x01f481bc5f0ff84a74ad6cdf6fdef4bf6179625372d8c0c5e1
522 0x0025e399f2903712ccf3ea9e3a1ad17fb0b3201b6af7ce1b05
523 , curveEccN = 0x01000000000000000000000000c7f34a778f443acc920eba49
524 , curveEccH = 2
525 }
526typeSEC_t193r2 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000008001
527paramSEC_t193r2 = CurveParameters
528 { curveEccA = 0x0163f35a5137c2ce3ea6ed8667190b0bc43ecd69977702709b
529 , curveEccB = 0x00c9bb9e8927d4d64c377e2ab2856a5b16e3efb7f61d4316ae
530 , curveEccG = Point 0x00d9b67d192e0367c803f39e1a7e82ca14a651350aae617e8f
531 0x01ce94335607c304ac29e7defbd9ca01f596f927224cdecf6c
532 , curveEccN = 0x010000000000000000000000015aab561b005413ccd4ee99d5
533 , curveEccH = 2
534 }
535typeSEC_t233k1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000000000000000004000000000000000001
536paramSEC_t233k1 = CurveParameters
537 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000
538 , curveEccB = 0x000000000000000000000000000000000000000000000000000000000001
539 , curveEccG = Point 0x017232ba853a7e731af129f22ff4149563a419c26bf50a4c9d6eefad6126
540 0x01db537dece819b7f70f555a67c427a8cd9bf18aeb9b56e0c11056fae6a3
541 , curveEccN = 0x008000000000000000000000000000069d5bb915bcd46efb1ad5f173abdf
542 , curveEccH = 4
543 }
544typeSEC_t233r1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000000000000000004000000000000000001
545paramSEC_t233r1 = CurveParameters
546 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000001
547 , curveEccB = 0x0066647ede6c332c7f8c0923bb58213b333b20e9ce4281fe115f7d8f90ad
548 , curveEccG = Point 0x00fac9dfcbac8313bb2139f1bb755fef65bc391f8b36f8f8eb7371fd558b
549 0x01006a08a41903350678e58528bebf8a0beff867a7ca36716f7e01f81052
550 , curveEccN = 0x01000000000000000000000000000013e974e72f8a6922031d2603cfe0d7
551 , curveEccH = 2
552 }
553typeSEC_t239k1 = CurveBinary $ CurveBinaryParam 0x800000000000000000004000000000000000000000000000000000000001
554paramSEC_t239k1 = CurveParameters
555 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000
556 , curveEccB = 0x000000000000000000000000000000000000000000000000000000000001
557 , curveEccG = Point 0x29a0b6a887a983e9730988a68727a8b2d126c44cc2cc7b2a6555193035dc
558 0x76310804f12e549bdb011c103089e73510acb275fc312a5dc6b76553f0ca
559 , curveEccN = 0x2000000000000000000000000000005a79fec67cb6e91f1c1da800e478a5
560 , curveEccH = 4
561 }
562typeSEC_t283k1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000000000000000000000000000000010a1
563paramSEC_t283k1 = CurveParameters
564 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000
565 , curveEccB = 0x000000000000000000000000000000000000000000000000000000000000000000000001
566 , curveEccG = Point 0x0503213f78ca44883f1a3b8162f188e553cd265f23c1567a16876913b0c2ac2458492836
567 0x01ccda380f1c9e318d90f95d07e5426fe87e45c0e8184698e45962364e34116177dd2259
568 , curveEccN = 0x01ffffffffffffffffffffffffffffffffffe9ae2ed07577265dff7f94451e061e163c61
569 , curveEccH = 4
570 }
571typeSEC_t283r1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000000000000000000000000000000010a1
572paramSEC_t283r1 = CurveParameters
573 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000001
574 , curveEccB = 0x027b680ac8b8596da5a4af8a19a0303fca97fd7645309fa2a581485af6263e313b79a2f5
575 , curveEccG = Point 0x05f939258db7dd90e1934f8c70b0dfec2eed25b8557eac9c80e2e198f8cdbecd86b12053
576 0x03676854fe24141cb98fe6d4b20d02b4516ff702350eddb0826779c813f0df45be8112f4
577 , curveEccN = 0x03ffffffffffffffffffffffffffffffffffef90399660fc938a90165b042a7cefadb307
578 , curveEccH = 2
579 }
580typeSEC_t409k1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001
581paramSEC_t409k1 = CurveParameters
582 { curveEccA = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
583 , curveEccB = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
584 , curveEccG = Point 0x0060f05f658f49c1ad3ab1890f7184210efd0987e307c84c27accfb8f9f67cc2c460189eb5aaaa62ee222eb1b35540cfe9023746
585 0x01e369050b7c4e42acba1dacbf04299c3460782f918ea427e6325165e9ea10e3da5f6c42e9c55215aa9ca27a5863ec48d8e0286b
586 , curveEccN = 0x007ffffffffffffffffffffffffffffffffffffffffffffffffffe5f83b2d4ea20400ec4557d5ed3e3e7ca5b4b5c83b8e01e5fcf
587 , curveEccH = 4
588 }
589typeSEC_t409r1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001
590paramSEC_t409r1 = CurveParameters
591 { curveEccA = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
592 , curveEccB = 0x0021a5c2c8ee9feb5c4b9a753b7b476b7fd6422ef1f3dd674761fa99d6ac27c8a9a197b272822f6cd57a55aa4f50ae317b13545f
593 , curveEccG = Point 0x015d4860d088ddb3496b0c6064756260441cde4af1771d4db01ffe5b34e59703dc255a868a1180515603aeab60794e54bb7996a7
594 0x0061b1cfab6be5f32bbfa78324ed106a7636b9c5a7bd198d0158aa4f5488d08f38514f1fdf4b4f40d2181b3681c364ba0273c706
595 , curveEccN = 0x010000000000000000000000000000000000000000000000000001e2aad6a612f33307be5fa47c3c9e052f838164cd37d9a21173
596 , curveEccH = 2
597 }
598typeSEC_t571k1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425
599paramSEC_t571k1 = CurveParameters
600 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
601 , curveEccB = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
602 , curveEccG = Point 0x026eb7a859923fbc82189631f8103fe4ac9ca2970012d5d46024804801841ca44370958493b205e647da304db4ceb08cbbd1ba39494776fb988b47174dca88c7e2945283a01c8972
603 0x0349dc807f4fbf374f4aeade3bca95314dd58cec9f307a54ffc61efc006d8a2c9d4979c0ac44aea74fbebbb9f772aedcb620b01a7ba7af1b320430c8591984f601cd4c143ef1c7a3
604 , curveEccN = 0x020000000000000000000000000000000000000000000000000000000000000000000000131850e1f19a63e4b391a8db917f4138b630d84be5d639381e91deb45cfe778f637c1001
605 , curveEccH = 4
606 }
607typeSEC_t571r1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425
608paramSEC_t571r1 = CurveParameters
609 { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
610 , curveEccB = 0x02f40e7e2221f295de297117b7f3d62f5c6a97ffcb8ceff1cd6ba8ce4a9a18ad84ffabbd8efa59332be7ad6756a66e294afd185a78ff12aa520e4de739baca0c7ffeff7f2955727a
611 , curveEccG = Point 0x0303001d34b856296c16c0d40d3cd7750a93d1d2955fa80aa5f40fc8db7b2abdbde53950f4c0d293cdd711a35b67fb1499ae60038614f1394abfa3b4c850d927e1e7769c8eec2d19
612 0x037bf27342da639b6dccfffeb73d69d78c6c27a6009cbbca1980f8533921e8a684423e43bab08a576291af8f461bb2a8b3531d2f0485c19b16e2f1516e23dd3c1a4827af1b8ac15b
613 , curveEccN = 0x03ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe661ce18ff55987308059b186823851ec7dd9ca1161de93d5174d66e8382e9bb2fe84e47
614 , curveEccH = 2
615 }
diff --git a/src/Crypto/Error/Types.hs b/src/Crypto/Error/Types.hs
new file mode 100644
index 00000000..4aaf4e04
--- /dev/null
+++ b/src/Crypto/Error/Types.hs
@@ -0,0 +1,106 @@
1-- |
2-- Module : Crypto.Error.Types
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : stable
6-- Portability : Good
7--
8-- Cryptographic Error enumeration and handling
9--
10{-# LANGUAGE DeriveDataTypeable #-}
11module Crypto.Error.Types
12 ( CryptoError(..)
13 , CryptoFailable(..)
14 , throwCryptoErrorIO
15 , throwCryptoError
16 , onCryptoFailure
17 , eitherCryptoError
18 , maybeCryptoError
19 ) where
20
21import qualified Control.Exception as E
22import Data.Data
23
24import Crypto.Internal.Imports
25
26-- | Enumeration of all possible errors that can be found in this library
27data CryptoError =
28 -- symmetric cipher errors
29 CryptoError_KeySizeInvalid
30 | CryptoError_IvSizeInvalid
31 | CryptoError_AEADModeNotSupported
32 -- public key cryptography error
33 | CryptoError_SecretKeySizeInvalid
34 | CryptoError_SecretKeyStructureInvalid
35 | CryptoError_PublicKeySizeInvalid
36 | CryptoError_SharedSecretSizeInvalid
37 -- elliptic cryptography error
38 | CryptoError_EcScalarOutOfBounds
39 | CryptoError_PointSizeInvalid
40 | CryptoError_PointFormatInvalid
41 | CryptoError_PointFormatUnsupported
42 | CryptoError_PointCoordinatesInvalid
43 -- Message authentification error
44 | CryptoError_MacKeyInvalid
45 | CryptoError_AuthenticationTagSizeInvalid
46 deriving (Show,Eq,Enum,Data,Typeable)
47
48instance E.Exception CryptoError
49
50-- | A simple Either like type to represent a computation that can fail
51--
52-- 2 possibles values are:
53--
54-- * 'CryptoPassed' : The computation succeeded, and contains the result of the computation
55--
56-- * 'CryptoFailed' : The computation failed, and contains the cryptographic error associated
57--
58data CryptoFailable a =
59 CryptoPassed a
60 | CryptoFailed CryptoError
61 deriving (Show)
62
63instance Eq a => Eq (CryptoFailable a) where
64 (==) (CryptoPassed a) (CryptoPassed b) = a == b
65 (==) (CryptoFailed e1) (CryptoFailed e2) = e1 == e2
66 (==) _ _ = False
67
68instance Functor CryptoFailable where
69 fmap f (CryptoPassed a) = CryptoPassed (f a)
70 fmap _ (CryptoFailed r) = CryptoFailed r
71
72instance Applicative CryptoFailable where
73 pure a = CryptoPassed a
74 (<*>) fm m = fm >>= \p -> m >>= \r2 -> return (p r2)
75instance Monad CryptoFailable where
76 return a = CryptoPassed a
77 (>>=) m1 m2 = do
78 case m1 of
79 CryptoPassed a -> m2 a
80 CryptoFailed e -> CryptoFailed e
81
82-- | Throw an CryptoError as exception on CryptoFailed result,
83-- otherwise return the computed value
84throwCryptoErrorIO :: CryptoFailable a -> IO a
85throwCryptoErrorIO (CryptoFailed e) = E.throwIO e
86throwCryptoErrorIO (CryptoPassed r) = return r
87
88-- | Same as 'throwCryptoErrorIO' but throw the error asynchronously.
89throwCryptoError :: CryptoFailable a -> a
90throwCryptoError (CryptoFailed e) = E.throw e
91throwCryptoError (CryptoPassed r) = r
92
93-- | Simple 'either' like combinator for CryptoFailable type
94onCryptoFailure :: (CryptoError -> r) -> (a -> r) -> CryptoFailable a -> r
95onCryptoFailure onError _ (CryptoFailed e) = onError e
96onCryptoFailure _ onSuccess (CryptoPassed r) = onSuccess r
97
98-- | Transform a CryptoFailable to an Either
99eitherCryptoError :: CryptoFailable a -> Either CryptoError a
100eitherCryptoError (CryptoFailed e) = Left e
101eitherCryptoError (CryptoPassed a) = Right a
102
103-- | Transform a CryptoFailable to a Maybe
104maybeCryptoError :: CryptoFailable a -> Maybe a
105maybeCryptoError (CryptoFailed _) = Nothing
106maybeCryptoError (CryptoPassed r) = Just r
diff --git a/src/Crypto/Internal/ByteArray.hs b/src/Crypto/Internal/ByteArray.hs
new file mode 100644
index 00000000..3a23152d
--- /dev/null
+++ b/src/Crypto/Internal/ByteArray.hs
@@ -0,0 +1,19 @@
1-- |
2-- Module : Crypto.Internal.ByteArray
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : stable
6-- Portability : Good
7--
8-- Simple and efficient byte array types
9--
10{-# OPTIONS_HADDOCK hide #-}
11module Crypto.Internal.ByteArray
12 ( module Data.ByteArray
13 , module Data.ByteArray.Mapping
14 , module Data.ByteArray.Encoding
15 ) where
16
17import Data.ByteArray
18import Data.ByteArray.Mapping
19import Data.ByteArray.Encoding
diff --git a/src/Crypto/Internal/Compat.hs b/src/Crypto/Internal/Compat.hs
new file mode 100644
index 00000000..a3712a7c
--- /dev/null
+++ b/src/Crypto/Internal/Compat.hs
@@ -0,0 +1,48 @@
1-- |
2-- Module : Crypto.Internal.Compat
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : stable
6-- Portability : Good
7--
8-- This module try to keep all the difference between versions of base
9-- or other needed packages, so that modules don't need to use CPP
10--
11{-# LANGUAGE CPP #-}
12module Crypto.Internal.Compat
13 ( unsafeDoIO
14 , popCount
15 , byteSwap64
16 ) where
17
18import System.IO.Unsafe
19import Data.Word
20import Data.Bits
21
22-- | perform io for hashes that do allocation and ffi.
23-- unsafeDupablePerformIO is used when possible as the
24-- computation is pure and the output is directly linked
25-- to the input. we also do not modify anything after it has
26-- been returned to the user.
27unsafeDoIO :: IO a -> a
28#if __GLASGOW_HASKELL__ > 704
29unsafeDoIO = unsafeDupablePerformIO
30#else
31unsafeDoIO = unsafePerformIO
32#endif
33
34#if !(MIN_VERSION_base(4,5,0))
35popCount :: Word64 -> Int
36popCount n = loop 0 n
37 where loop c 0 = c
38 loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1)
39#endif
40
41#if !(MIN_VERSION_base(4,7,0))
42byteSwap64 :: Word64 -> Word64
43byteSwap64 w =
44 (w `shiftR` 56) .|. (w `shiftL` 56)
45 .|. ((w `shiftR` 40) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 40)
46 .|. ((w `shiftR` 24) .&. 0xff0000) .|. ((w .&. 0xff0000) `shiftL` 24)
47 .|. ((w `shiftR` 8) .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8)
48#endif
diff --git a/src/Crypto/Internal/DeepSeq.hs b/src/Crypto/Internal/DeepSeq.hs
new file mode 100644
index 00000000..9da79881
--- /dev/null
+++ b/src/Crypto/Internal/DeepSeq.hs
@@ -0,0 +1,33 @@
1-- |
2-- Module : Crypto.Internal.DeepSeq
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : experimental
6-- Portability : unknown
7--
8-- Simple abstraction module to allow compilation without deepseq
9-- by defining our own NFData class if not compiling with deepseq
10-- support.
11--
12{-# LANGUAGE CPP #-}
13module Crypto.Internal.DeepSeq
14 ( NFData(..)
15 ) where
16
17#ifdef WITH_DEEPSEQ_SUPPORT
18import Control.DeepSeq
19#else
20import Data.Word
21import Data.ByteArray
22
23class NFData a where rnf :: a -> ()
24
25instance NFData Word8 where rnf w = w `seq` ()
26instance NFData Word16 where rnf w = w `seq` ()
27instance NFData Word32 where rnf w = w `seq` ()
28instance NFData Word64 where rnf w = w `seq` ()
29
30instance NFData Bytes where rnf b = b `seq` ()
31instance NFData ScrubbedBytes where rnf b = b `seq` ()
32
33#endif
diff --git a/src/Crypto/Internal/Imports.hs b/src/Crypto/Internal/Imports.hs
new file mode 100644
index 00000000..4ed44e16
--- /dev/null
+++ b/src/Crypto/Internal/Imports.hs
@@ -0,0 +1,16 @@
1-- |
2-- Module : Crypto.Internal.Imports
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : experimental
6-- Portability : unknown
7--
8module Crypto.Internal.Imports
9 ( module X
10 ) where
11
12import Data.Word as X
13import Control.Applicative as X
14import Control.Monad as X (forM, forM_, void)
15import Control.Arrow as X (first, second)
16import Crypto.Internal.DeepSeq as X
diff --git a/src/Crypto/PubKey/Curve25519.hs b/src/Crypto/PubKey/Curve25519.hs
new file mode 100644
index 00000000..42878691
--- /dev/null
+++ b/src/Crypto/PubKey/Curve25519.hs
@@ -0,0 +1,131 @@
1-- |
2-- Module : Crypto.PubKey.Curve25519
3-- License : BSD-style
4-- Maintainer : Vincent Hanquez <vincent@snarc.org>
5-- Stability : experimental
6-- Portability : unknown
7--
8-- Curve25519 support
9--
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE MagicHash #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13module Crypto.PubKey.Curve25519
14 ( SecretKey
15 , PublicKey
16 , DhSecret
17 -- * Smart constructors
18 , dhSecret
19 , publicKey
20 , secretKey
21 -- * methods
22 , dh
23 , toPublic
24 , generateSecretKey
25 ) where
26
27import Data.Bits
28import Data.Word
29import Foreign.Ptr
30import Foreign.Storable
31import GHC.Ptr
32
33-- import Crypto.Error
34import Crypto.Error.Types
35import Crypto.Internal.Compat
36import Crypto.Internal.Imports
37import Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes, Bytes, withByteArray)
38import qualified Crypto.Internal.ByteArray as B
39-- import Crypto.Error (CryptoFailable(..))
40import Crypto.Random
41
42-- | A Curve25519 Secret key
43newtype SecretKey = SecretKey ScrubbedBytes
44 deriving (Show,Eq,ByteArrayAccess,NFData)
45
46-- | A Curve25519 public key
47newtype PublicKey = PublicKey Bytes
48 deriving (Show,Eq,ByteArrayAccess,NFData)
49
50-- | A Curve25519 Diffie Hellman secret related to a
51-- public key and a secret key.
52newtype DhSecret = DhSecret ScrubbedBytes
53 deriving (Show,Eq,ByteArrayAccess,NFData)
54
55-- | Try to build a public key from a bytearray
56publicKey :: ByteArrayAccess bs => bs -> CryptoFailable PublicKey
57publicKey bs
58 | B.length bs == 32 = CryptoPassed $ PublicKey $ B.copyAndFreeze bs (\_ -> return ())
59 | otherwise = CryptoFailed CryptoError_PublicKeySizeInvalid
60
61-- | Try to build a secret key from a bytearray
62secretKey :: ByteArrayAccess bs => bs -> CryptoFailable SecretKey
63secretKey bs
64 | B.length bs == 32 = unsafeDoIO $ do
65 withByteArray bs $ \inp -> do
66 valid <- isValidPtr inp
67 if valid
68 then (CryptoPassed . SecretKey) <$> B.copy bs (\_ -> return ())
69 else return $ CryptoFailed CryptoError_SecretKeyStructureInvalid
70 | otherwise = CryptoFailed CryptoError_SecretKeySizeInvalid
71 where
72 -- e[0] &= 0xf8;
73 -- e[31] &= 0x7f;
74 -- e[31] |= 40;
75 isValidPtr :: Ptr Word8 -> IO Bool
76 isValidPtr _ = do
77 --b0 <- peekElemOff inp 0
78 --b31 <- peekElemOff inp 31
79 return True
80{-
81 return $ and [ testBit b0 0 == False
82 , testBit b0 1 == False
83 , testBit b0 2 == False
84 , testBit b31 7 == False
85 , testBit b31 6 == True
86 ]
87-}
88{-# NOINLINE secretKey #-}
89
90-- | Create a DhSecret from a bytearray object
91dhSecret :: ByteArrayAccess b => b -> CryptoFailable DhSecret
92dhSecret bs
93 | B.length bs == 32 = CryptoPassed $ DhSecret $ B.copyAndFreeze bs (\_ -> return ())
94 | otherwise = CryptoFailed CryptoError_SharedSecretSizeInvalid
95
96-- | Compute the Diffie Hellman secret from a public key and a secret key
97dh :: PublicKey -> SecretKey -> DhSecret
98dh (PublicKey pub) (SecretKey sec) = DhSecret <$>
99 B.allocAndFreeze 32 $ \result ->
100 withByteArray sec $ \psec ->
101 withByteArray pub $ \ppub ->
102 ccryptonite_curve25519 result psec ppub
103{-# NOINLINE dh #-}
104
105-- | Create a public key from a secret key
106toPublic :: SecretKey -> PublicKey
107toPublic (SecretKey sec) = PublicKey <$>
108 B.allocAndFreeze 32 $ \result ->
109 withByteArray sec $ \psec ->
110 ccryptonite_curve25519 result psec basePoint
111 where
112 basePoint = Ptr "\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
113{-# NOINLINE toPublic #-}
114
115-- | Generate a secret key.
116generateSecretKey :: MonadRandom m => m SecretKey
117generateSecretKey = tweakToSecretKey <$> getRandomBytes 32
118 where
119 tweakToSecretKey :: ScrubbedBytes -> SecretKey
120 tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do
121 modifyByte inp 0 (\e0 -> e0 .&. 0xf8)
122 modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40)
123
124 modifyByte :: Ptr Word8 -> Int -> (Word8 -> Word8) -> IO ()
125 modifyByte p n f = peekByteOff p n >>= pokeByteOff p n . f
126
127foreign import ccall "cryptonite_curve25519_donna"
128 ccryptonite_curve25519 :: Ptr Word8 -- ^ public
129 -> Ptr Word8 -- ^ secret
130 -> Ptr Word8 -- ^ basepoint
131 -> IO ()
diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs
index fa8071d5..2535c05c 100644
--- a/src/Network/BitTorrent/DHT.hs
+++ b/src/Network/BitTorrent/DHT.hs
@@ -234,7 +234,7 @@ bootstrap :: forall raw dht u ip.
234 , Show u 234 , Show u
235 , Default u 235 , Default u
236 , Serialize u 236 , Serialize u
237 ) => Maybe BS.ByteString -> [NodeAddr ip] -> DHT raw dht u ip () 237 ) => Maybe BS.ByteString -> [PacketDestination dht] -> DHT raw dht u ip ()
238bootstrap mbs startNodes = do 238bootstrap mbs startNodes = do
239 restored <- 239 restored <-
240 case decode <$> mbs of 240 case decode <$> mbs of
@@ -250,7 +250,7 @@ bootstrap mbs startNodes = do
250 return ( ns :: [NodeInfo dht ip u] ) 250 return ( ns :: [NodeInfo dht ip u] )
251 input_nodes <- (restored ++) . T.toList <$> getTable 251 input_nodes <- (restored ++) . T.toList <$> getTable
252 -- Step 1: Use iterative searches to flesh out the table.. 252 -- Step 1: Use iterative searches to flesh out the table..
253 do let knowns = map (map $ nodeAddr . fst) input_nodes 253 do let knowns = map (map $ fst) input_nodes
254 -- Below, we reverse the nodes since the table serialization puts the 254 -- Below, we reverse the nodes since the table serialization puts the
255 -- nearest nodes last and we want to choose a similar node id to bootstrap 255 -- nearest nodes last and we want to choose a similar node id to bootstrap
256 -- faster. 256 -- faster.
@@ -265,7 +265,7 @@ bootstrap mbs startNodes = do
265 when (null ns) $ do 265 when (null ns) $ do
266 -- TODO filter duplicated in startNodes list 266 -- TODO filter duplicated in startNodes list
267 -- TODO retransmissions for startNodes 267 -- TODO retransmissions for startNodes
268 (aliveNodes,_) <- unzip <$> queryParallel (pingQ <$> startNodes) 268 (aliveNodes,_) <- unzip <$> queryParallel (coldPingQ <$> startNodes)
269 _ <- searchAll $ take 2 aliveNodes 269 _ <- searchAll $ take 2 aliveNodes
270 return () 270 return ()
271 -- Step 2: Repeatedly refresh incomplete buckets until the table is full. 271 -- Step 2: Repeatedly refresh incomplete buckets until the table is full.
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index 77fede94..60b772b3 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -35,6 +35,7 @@ module Network.BitTorrent.DHT.Query
35 -- single response. 35 -- single response.
36 , Iteration 36 , Iteration
37 , pingQ 37 , pingQ
38 , coldPingQ
38 , findNodeQ 39 , findNodeQ
39 , getPeersQ 40 , getPeersQ
40 , announceQ 41 , announceQ
@@ -316,44 +317,72 @@ pingQ :: forall raw dht u ip.
316 , FiniteBits (NodeId dht) 317 , FiniteBits (NodeId dht)
317 , Show (NodeId dht) 318 , Show (NodeId dht)
318 , Show (QueryMethod dht) 319 , Show (QueryMethod dht)
319 ) => NodeAddr ip -> DHT raw dht u ip (NodeInfo dht ip u , Maybe ReflectedIP) 320 ) => NodeInfo dht ip u -> DHT raw dht u ip (NodeInfo dht ip u , Maybe ReflectedIP)
320pingQ addr = do 321pingQ ni = do
321 let ping = DHT.pingMessage (Proxy :: Proxy dht) 322 let ping = DHT.pingMessage (Proxy :: Proxy dht)
322 (nid, pong, mip) <- queryNode' addr ping 323 (nid, pong, mip) <- queryNode' ni ping
323 let _ = pong `asTypeOf` ping 324 let _ = pong `asTypeOf` ping
324 -- (nid, PingPayload{}, mip) <- queryNode' addr PingPayload {isPong=False, pingId=pid} 325 -- (nid, PingPayload{}, mip) <- queryNode' addr PingPayload {isPong=False, pingId=pid}
325 return (NodeInfo nid addr def, mip) 326 return (NodeInfo nid (nodeAddr ni) def, mip)
327
328-- | The most basic query. May be used to check if the given node is
329-- alive or get its 'NodeId'.
330coldPingQ :: forall raw dht u ip.
331 ( DHT.Kademlia dht
332 , Address ip
333 , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
334 , Default u
335 , Show u
336 , Ord (TransactionID dht)
337 , Serialize (TransactionID dht)
338 , WireFormat raw dht
339 , SerializableTo raw (Response dht (Ping dht))
340 , SerializableTo raw (Query dht (Ping dht))
341 , Ord (NodeId dht)
342 , FiniteBits (NodeId dht)
343 , Show (NodeId dht)
344 , Show (QueryMethod dht)
345 ) => PacketDestination dht -> DHT raw dht u ip (NodeInfo dht ip u , Maybe ReflectedIP)
346coldPingQ dest = do
347 let ping = DHT.pingMessage (Proxy :: Proxy dht)
348 naddr <- maybe (throwIO $ QueryFailed ProtocolError "unable to construct NodeAddr from PacketDestination")
349 return
350 $ fromAddr dest
351 (nid, pong, mip) <- coldQueryNode' naddr dest ping
352 let _ = pong `asTypeOf` ping
353 -- (nid, PingPayload{}, mip) <- queryNode' addr PingPayload {isPong=False, pingId=pid}
354 return (NodeInfo nid naddr def, mip)
326 355
327-- TODO [robustness] match range of returned node ids with the 356-- TODO [robustness] match range of returned node ids with the
328-- expected range and either filter bad nodes or discard response at 357-- expected range and either filter bad nodes or discard response at
329-- all throwing an exception 358-- all throwing an exception
330-- findNodeQ :: Address ip => TableKey key => key -> IterationI ip NodeInfo 359-- findNodeQ :: Address ip => TableKey key => key -> IterationI ip NodeInfo
331findNodeQ proxy key NodeInfo {..} = do 360findNodeQ proxy key ni = do
332 closest <- fmap DHT.foundNodes $ DHT.findNodeMessage proxy key <@> nodeAddr 361 closest <- fmap DHT.foundNodes $ DHT.findNodeMessage proxy key <@> ni
333 $(logInfoS) "findNodeQ" $ "NodeFound\n" 362 $(logInfoS) "findNodeQ" $ "NodeFound\n"
334 <> T.pack (L.unlines $ L.map ((' ' :) . show . pPrint) closest) 363 <> T.pack (L.unlines $ L.map ((' ' :) . show . pPrint) closest)
335 return $ Right closest 364 return $ Right closest
336 365
337#ifdef VERSION_bencoding 366#ifdef VERSION_bencoding
338getPeersQ :: Address ip => InfoHash -> Iteration BValue KMessageOf () ip PeerAddr 367getPeersQ :: Address ip => InfoHash -> Iteration BValue KMessageOf () ip PeerAddr
339getPeersQ topic NodeInfo {..} = do 368getPeersQ topic ni = do
340 GotPeers {..} <- GetPeers topic <@> nodeAddr 369 GotPeers {..} <- GetPeers topic <@> ni
341 let dist = distance (toNodeId topic) nodeId 370 let dist = distance (toNodeId topic) (nodeId ni)
342 $(logInfoS) "getPeersQ" $ T.pack 371 $(logInfoS) "getPeersQ" $ T.pack
343 $ "distance: " <> render (pPrint dist) <> " , result: " 372 $ "distance: " <> render (pPrint dist) <> " , result: "
344 <> case peers of { Left _ -> "NODES"; Right _ -> "PEERS" } 373 <> case peers of { Left _ -> "NODES"; Right _ -> "PEERS" }
345 return peers 374 return peers
346 375
347announceQ :: Address ip => InfoHash -> PortNumber -> Iteration BValue KMessageOf () ip NodeAddr 376announceQ :: Address ip => InfoHash -> PortNumber -> Iteration BValue KMessageOf () ip NodeAddr
348announceQ ih p NodeInfo {..} = do 377announceQ ih p ni = do
349 GotPeers {..} <- GetPeers ih <@> nodeAddr 378 GotPeers {..} <- GetPeers ih <@> ni
350 case peers of 379 case peers of
351 Left ns 380 Left ns
352 | False -> undefined -- TODO check if we can announce 381 | False -> undefined -- TODO check if we can announce
353 | otherwise -> return (Left ns) 382 | otherwise -> return (Left ns)
354 Right _ -> do -- TODO *probably* add to peer cache 383 Right _ -> do -- TODO *probably* add to peer cache
355 Announced <- Announce False ih Nothing p grantedToken <@> nodeAddr 384 Announced <- Announce False ih Nothing p grantedToken <@> ni
356 return (Right [nodeAddr]) 385 return (Right [nodeAddr ni])
357#endif 386#endif
358 387
359{----------------------------------------------------------------------- 388{-----------------------------------------------------------------------
@@ -393,7 +422,7 @@ ioFindNode :: ( DHT.Kademlia dht
393ioFindNode ih = do 422ioFindNode ih = do
394 session <- ask 423 session <- ask
395 return $ \ni -> runDHT session $ do 424 return $ \ni -> runDHT session $ do
396 ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> nodeAddr ni 425 ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> ni
397 let ns' = L.map (fmap (const def)) ns 426 let ns' = L.map (fmap (const def)) ns
398 return $ L.partition (\n -> nodeId n /= toNodeId ih) ns' 427 return $ L.partition (\n -> nodeId n /= toNodeId ih) ns'
399 428
@@ -422,7 +451,7 @@ ioFindNodes :: ( DHT.Kademlia dht
422ioFindNodes ih = do 451ioFindNodes ih = do
423 session <- ask 452 session <- ask
424 return $ \ni -> runDHT session $ do 453 return $ \ni -> runDHT session $ do
425 ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> nodeAddr ni 454 ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> ni
426 let ns' = L.map (fmap (const def)) ns 455 let ns' = L.map (fmap (const def)) ns
427 return ([], ns') 456 return ([], ns')
428 457
@@ -504,9 +533,9 @@ probeNode :: ( Default u
504 , FiniteBits (NodeId dht) 533 , FiniteBits (NodeId dht)
505 , Show (NodeId dht) 534 , Show (NodeId dht)
506 , Show (QueryMethod dht) 535 , Show (QueryMethod dht)
507 ) => NodeAddr ip -> DHT raw dht u ip (Bool , Maybe ReflectedIP) 536 ) => NodeInfo dht ip u -> DHT raw dht u ip (Bool , Maybe ReflectedIP)
508probeNode addr = do 537probeNode addr = do
509 $(logDebugS) "routing.questionable_node" (T.pack (render (pPrint addr))) 538 $(logDebugS) "routing.questionable_node" (T.pack (render (pPrint $ nodeAddr addr)))
510 result <- try $ pingQ addr 539 result <- try $ pingQ addr
511 let _ = fmap (const ()) result :: Either QueryFailure () 540 let _ = fmap (const ()) result :: Either QueryFailure ()
512 return $ either (const (False,Nothing)) (\(_,mip)->(True,mip)) result 541 return $ either (const (False,Nothing)) (\(_,mip)->(True,mip)) result
@@ -549,7 +578,7 @@ refreshNodes nid = do
549 $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length ns)) <> " nodes." 578 $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length ns)) <> " nodes."
550 _ <- queryParallel $ flip L.map ns $ \n -> do 579 _ <- queryParallel $ flip L.map ns $ \n -> do
551 $(logWarnS) "refreshNodes" $ "received node: " <> T.pack (show (pPrint n)) 580 $(logWarnS) "refreshNodes" $ "received node: " <> T.pack (show (pPrint n))
552 pingQ (nodeAddr n) 581 pingQ n
553 -- pingQ takes care of inserting the node. 582 -- pingQ takes care of inserting the node.
554 return () 583 return ()
555 return () -- \$ L.concat nss 584 return () -- \$ L.concat nss
@@ -622,7 +651,7 @@ insertNode1 = do
622 , fallbackID = nid :: NodeId dht 651 , fallbackID = nid :: NodeId dht
623 , adjustID = dhtAdjustID Proxy (DHT.fallbackID params) :: SockAddr -> Event dht ip u -> NodeId dht 652 , adjustID = dhtAdjustID Proxy (DHT.fallbackID params) :: SockAddr -> Event dht ip u -> NodeId dht
624 , logMessage = logm :: Char -> String -> IO () 653 , logMessage = logm :: Char -> String -> IO ()
625 , pingProbe = probe :: NodeAddr ip -> IO (Bool, Maybe ReflectedIP) 654 , pingProbe = probe :: NodeInfo dht ip u -> IO (Bool, Maybe ReflectedIP)
626 } 655 }
627 tbl <- asks routingInfo 656 tbl <- asks routingInfo
628 let state = DHT.TableKeeper 657 let state = DHT.TableKeeper
@@ -651,7 +680,7 @@ queryNode :: forall raw dht u a b ip.
651 , Show (QueryMethod dht) 680 , Show (QueryMethod dht)
652 , SerializableTo raw (Response dht (Ping dht)) 681 , SerializableTo raw (Response dht (Ping dht))
653 , SerializableTo raw (Query dht (Ping dht)) 682 , SerializableTo raw (Query dht (Ping dht))
654 ) => NodeAddr ip -> a -> DHT raw dht u ip (NodeId dht, b) 683 ) => NodeInfo dht ip u -> a -> DHT raw dht u ip (NodeId dht, b)
655queryNode addr q = fmap (\(n,b,_) -> (n,b)) $ queryNode' addr q 684queryNode addr q = fmap (\(n,b,_) -> (n,b)) $ queryNode' addr q
656 685
657queryNode' :: forall raw dht u a b ip. 686queryNode' :: forall raw dht u a b ip.
@@ -672,15 +701,39 @@ queryNode' :: forall raw dht u a b ip.
672 , Show (QueryMethod dht) 701 , Show (QueryMethod dht)
673 , SerializableTo raw (Response dht (Ping dht)) 702 , SerializableTo raw (Response dht (Ping dht))
674 , SerializableTo raw (Query dht (Ping dht)) 703 , SerializableTo raw (Query dht (Ping dht))
675 ) => NodeAddr ip -> a -> DHT raw dht u ip (NodeId dht, b, Maybe ReflectedIP) 704 ) => NodeInfo dht ip u -> a -> DHT raw dht u ip (NodeId dht, b, Maybe ReflectedIP)
676queryNode' addr q = do 705queryNode' ni q = do
677 nid <- myNodeIdAccordingTo addr 706 let addr = nodeAddr ni
707 dest = makeAddress (Left $ nodeId ni) (toSockAddr addr)
708 coldQueryNode' addr dest q
709
710coldQueryNode' :: forall raw dht u a b ip.
711 ( Address ip
712 , Default u
713 , Show u
714 , DHT.Kademlia dht
715 , KRPC dht (Query dht a) (Response dht b)
716 , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
717 , Ord (TransactionID dht)
718 , Serialize (TransactionID dht)
719 , WireFormat raw dht
720 , SerializableTo raw (Response dht b)
721 , SerializableTo raw (Query dht a)
722 , Ord (NodeId dht)
723 , FiniteBits (NodeId dht)
724 , Show (NodeId dht)
725 , Show (QueryMethod dht)
726 , SerializableTo raw (Response dht (Ping dht))
727 , SerializableTo raw (Query dht (Ping dht))
728 ) => NodeAddr ip -> PacketDestination dht -> a -> DHT raw dht u ip (NodeId dht, b, Maybe ReflectedIP)
729coldQueryNode' addr dest q = do
730 nid <- myNodeIdAccordingTo $ fromMaybe (error "TODO: coldQueryNode' myNodeIdAccordingTo") $ fromAddr dest
678 dta <- asks dhtData 731 dta <- asks dhtData
679 qextra <- liftIO $ makeQueryExtra dta nid (Proxy :: Proxy (Query dht q)) (Proxy :: Proxy (Response dht b)) 732 qextra <- liftIO $ makeQueryExtra dta nid (Proxy :: Proxy (Query dht q)) (Proxy :: Proxy (Response dht b))
680 let read_only = False -- TODO: check for NAT issues. (BEP 43) 733 let read_only = False -- TODO: check for NAT issues. (BEP 43)
681 -- let KRPC.Method name = KRPC.method :: KRPC.Method dht (Query dht a) (Response dht b) 734 -- let KRPC.Method name = KRPC.method :: KRPC.Method dht (Query dht a) (Response dht b)
682 mgr <- asks manager 735 mgr <- asks manager
683 (Response rextra r, remoteId, witnessed_ip) <- liftIO $ query' mgr (toSockAddr addr) (Query qextra q) 736 (Response rextra r, remoteId, witnessed_ip) <- liftIO $ query' mgr dest (Query qextra q)
684 -- \$(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip) 737 -- \$(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip)
685 -- <> " by " <> T.pack (show (toSockAddr addr)) 738 -- <> " by " <> T.pack (show (toSockAddr addr))
686 _ <- insertNode (NodeInfo remoteId addr def) witnessed_ip 739 _ <- insertNode (NodeInfo remoteId addr def) witnessed_ip
@@ -704,6 +757,6 @@ queryNode' addr q = do
704 , SerializableTo raw (Query dht (Ping dht)) 757 , SerializableTo raw (Query dht (Ping dht))
705 , WireFormat raw dht 758 , WireFormat raw dht
706 , Kademlia dht 759 , Kademlia dht
707 ) => a -> NodeAddr ip -> DHT raw dht u ip b 760 ) => a -> NodeInfo dht ip u -> DHT raw dht u ip b
708q <@> addr = snd <$> queryNode addr q 761q <@> addr = snd <$> queryNode addr q
709{-# INLINE (<@>) #-} 762{-# INLINE (<@>) #-}
diff --git a/src/Network/DHT.hs b/src/Network/DHT.hs
index 0dab29cd..285cf9ff 100644
--- a/src/Network/DHT.hs
+++ b/src/Network/DHT.hs
@@ -115,7 +115,7 @@ insertNode param@TableParameters{..} state info witnessed_ip0 = do
115 myThreadId >>= flip labelThread "DHT.insertNode.pingResults" 115 myThreadId >>= flip labelThread "DHT.insertNode.pingResults"
116 forM_ ps $ \(CheckPing ns)-> do 116 forM_ ps $ \(CheckPing ns)-> do
117 forM_ ns $ \n -> do 117 forM_ ns $ \n -> do
118 (b,mip) <- pingProbe (nodeAddr n) 118 (b,mip) <- pingProbe n
119 let alive = PingResult n b 119 let alive = PingResult n b
120 logMessage 'D' $ "PingResult "++show (nodeId n,b) 120 logMessage 'D' $ "PingResult "++show (nodeId n,b)
121 _ <- join $ atomically $ atomicInsert param state tm alive mip 121 _ <- join $ atomically $ atomicInsert param state tm alive mip
diff --git a/src/Network/DHT/Types.hs b/src/Network/DHT/Types.hs
index 0102a53f..47f98ebe 100644
--- a/src/Network/DHT/Types.hs
+++ b/src/Network/DHT/Types.hs
@@ -18,7 +18,7 @@ import GHC.Generics
18data TableParameters msg ip u = TableParameters 18data TableParameters msg ip u = TableParameters
19 { maxBuckets :: Int 19 { maxBuckets :: Int
20 , fallbackID :: NodeId msg 20 , fallbackID :: NodeId msg
21 , pingProbe :: NodeAddr ip -> IO (Bool, Maybe ReflectedIP) 21 , pingProbe :: NodeInfo msg ip u -> IO (Bool, Maybe ReflectedIP)
22 , logMessage :: Char -> String -> IO () 22 , logMessage :: Char -> String -> IO ()
23 , adjustID :: SockAddr -> Event msg ip u -> NodeId msg 23 , adjustID :: SockAddr -> Event msg ip u -> NodeId msg
24 } 24 }
diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs
index 1376748f..ca968a8c 100644
--- a/src/Network/DatagramServer.hs
+++ b/src/Network/DatagramServer.hs
@@ -329,7 +329,7 @@ query :: forall h a b raw msg.
329 , SerializableTo raw a 329 , SerializableTo raw a
330 , WireFormat raw msg 330 , WireFormat raw msg
331 , KRPC msg a b 331 , KRPC msg a b
332 ) => Manager raw msg -> SockAddr -> a -> IO b 332 ) => Manager raw msg -> PacketDestination msg -> a -> IO b
333query mgr addr params = queryK mgr addr params (\_ x _ _ -> x) 333query mgr addr params = queryK mgr addr params (\_ x _ _ -> x)
334 334
335-- | Like 'query' but possibly returns your externally routable IP address. 335-- | Like 'query' but possibly returns your externally routable IP address.
@@ -340,7 +340,7 @@ query' :: forall h a b raw msg.
340 , Serialize (TransactionID msg) 340 , Serialize (TransactionID msg)
341 , SerializableTo raw a , WireFormat raw msg 341 , SerializableTo raw a , WireFormat raw msg
342 , KRPC msg a b 342 , KRPC msg a b
343 ) => Manager raw msg -> SockAddr -> a -> IO (b , NodeId msg, Maybe ReflectedIP) 343 ) => Manager raw msg -> PacketDestination msg -> a -> IO (b , NodeId msg, Maybe ReflectedIP)
344query' mgr addr params = queryK mgr addr params (\_ b nid ip -> (b,nid,ip)) 344query' mgr addr params = queryK mgr addr params (\_ b nid ip -> (b,nid,ip))
345 345
346-- | Enqueue a query, but give us the complete BEncoded content sent by the 346-- | Enqueue a query, but give us the complete BEncoded content sent by the
@@ -354,7 +354,7 @@ queryRaw :: forall h a b raw msg.
354 , SerializableTo raw a 354 , SerializableTo raw a
355 , WireFormat raw msg 355 , WireFormat raw msg
356 , KRPC msg a b 356 , KRPC msg a b
357 ) => Manager raw msg -> SockAddr -> a -> IO (b , raw) 357 ) => Manager raw msg -> PacketDestination msg -> a -> IO (b , raw)
358queryRaw mgr addr params = queryK mgr addr params (\raw x _ _ -> (x,raw)) 358queryRaw mgr addr params = queryK mgr addr params (\raw x _ _ -> (x,raw))
359 359
360queryK :: forall h a b x raw msg. 360queryK :: forall h a b x raw msg.
@@ -366,11 +366,12 @@ queryK :: forall h a b x raw msg.
366 , Serialize (TransactionID msg) 366 , Serialize (TransactionID msg)
367 , KRPC msg a b 367 , KRPC msg a b
368 ) => 368 ) =>
369 Manager raw msg -> SockAddr -> a -> (raw -> b -> NodeId msg -> Maybe ReflectedIP -> x) -> IO x 369 Manager raw msg -> PacketDestination msg -> a -> (raw -> b -> NodeId msg -> Maybe ReflectedIP -> x) -> IO x
370queryK mgr@Manager{..} addr params kont = do 370queryK mgr@Manager{..} dest params kont = do
371 tid <- liftIO $ genTransactionId transactionCounter 371 tid <- liftIO $ genTransactionId transactionCounter
372 let Method meth = method :: Method msg a b 372 let addr = toSockAddr dest
373 let signature = querySignature meth tid addr 373 Method meth = method :: Method msg a b
374 signature = querySignature meth tid addr
374 logMsg 'D' "query.sending" signature 375 logMsg 'D' "query.sending" signature
375 376
376 mres <- liftIO $ do 377 mres <- liftIO $ do
@@ -380,7 +381,7 @@ queryK mgr@Manager{..} addr params kont = do
380 ctx = error "TODO TOX ToxCipherContext or () for Mainline" 381 ctx = error "TODO TOX ToxCipherContext or () for Mainline"
381 q <- buildQuery cli addr meth tid params 382 q <- buildQuery cli addr meth tid params
382 let qb = encodePayload (q :: msg a) :: msg raw 383 let qb = encodePayload (q :: msg a) :: msg raw
383 qbs = encodeHeaders ctx qb 384 qbs = encodeHeaders ctx qb dest
384 sendQuery sock addr qbs 385 sendQuery sock addr qbs
385 `onException` unregisterQuery (tid, addr) pendingCalls 386 `onException` unregisterQuery (tid, addr) pendingCalls
386 387
@@ -528,7 +529,8 @@ handleQuery mgr@Manager{..} hs meth raw q addr = void $ fork $ do
528 res <- dispatchHandler mgr hs meth q addr 529 res <- dispatchHandler mgr hs meth q addr
529 let res' = either buildError Just res 530 let res' = either buildError Just res
530 ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline" 531 ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline"
531 resbs = fmap (encodeHeaders ctx) res' :: Maybe BS.ByteString 532 dest = makeAddress (Right q) addr
533 resbs = fmap (\raw -> encodeHeaders ctx raw dest) res' :: Maybe BS.ByteString
532 -- TODO: Generalize this debug print. 534 -- TODO: Generalize this debug print.
533 -- resbe = either toBEncode toBEncode res 535 -- resbe = either toBEncode toBEncode res
534 -- .(logOther "q") \$ T.unlines 536 -- .(logOther "q") \$ T.unlines
diff --git a/src/Network/DatagramServer/Mainline.hs b/src/Network/DatagramServer/Mainline.hs
index 89a275c1..1f07b13f 100644
--- a/src/Network/DatagramServer/Mainline.hs
+++ b/src/Network/DatagramServer/Mainline.hs
@@ -79,6 +79,7 @@ import Data.Typeable
79import Network.Socket (SockAddr (..),PortNumber,HostAddress) 79import Network.Socket (SockAddr (..),PortNumber,HostAddress)
80import Text.PrettyPrint as PP hiding ((<>)) 80import Text.PrettyPrint as PP hiding ((<>))
81import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) 81import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
82import Data.Hashable
82 83
83 84
84-- | This transaction ID is generated by the querying node and is 85-- | This transaction ID is generated by the querying node and is
@@ -290,6 +291,9 @@ instance Envelope KMessageOf where
290 } 291 }
291 deriving (Show, Eq, Ord, Typeable) 292 deriving (Show, Eq, Ord, Typeable)
292 293
294 newtype PacketDestination KMessageOf = MainlineNode SockAddr
295 deriving (Show, Eq, Ord, Typeable)
296
293 envelopePayload (Q q) = queryArgs q 297 envelopePayload (Q q) = queryArgs q
294 envelopePayload (R r) = respVals r 298 envelopePayload (R r) = respVals r
295 envelopePayload (E _) = error "TODO: messagePayload for KError" 299 envelopePayload (E _) = error "TODO: messagePayload for KError"
@@ -302,6 +306,9 @@ instance Envelope KMessageOf where
302 envelopeClass (R r) = Response (respIP r) 306 envelopeClass (R r) = Response (respIP r)
303 envelopeClass (E e) = Error e 307 envelopeClass (E e) = Error e
304 308
309 -- replyAddress :: envelope a -> SockAddr -> PacketDestination envelope
310 makeAddress _ addr = MainlineNode addr
311
305 buildReply self addr qry response = 312 buildReply self addr qry response =
306 (R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr))) 313 (R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr)))
307 314
@@ -311,6 +318,20 @@ instance Envelope KMessageOf where
311 318
312 fromRoutableNode = not . queryIsReadOnly 319 fromRoutableNode = not . queryIsReadOnly
313 320
321instance Hashable (PacketDestination KMessageOf) where
322 hashWithSalt s (MainlineNode sockaddr) = hashWithSalt s (show sockaddr)
323
324-- Serialize, Pretty) PacketDestination KMessageOf = MainlineNode SockAddr
325instance Serialize (PacketDestination KMessageOf) where
326 put (MainlineNode addr) = putSockAddr addr
327 get = MainlineNode <$> getSockAddr
328
329instance Pretty (PacketDestination KMessageOf) where
330 pPrint (MainlineNode addr) = PP.text $ show addr
331
332instance Address (PacketDestination KMessageOf) where
333 toSockAddr (MainlineNode addr) = addr
334 fromSockAddr addr = Just $ MainlineNode addr
314 335
315instance WireFormat BValue KMessageOf where 336instance WireFormat BValue KMessageOf where
316 type SerializableTo BValue = BEncode 337 type SerializableTo BValue = BEncode
@@ -323,7 +344,7 @@ instance WireFormat BValue KMessageOf where
323 decodeHeaders _ = BE.fromBEncode 344 decodeHeaders _ = BE.fromBEncode
324 decodePayload kmsg = mapM BE.fromBEncode kmsg 345 decodePayload kmsg = mapM BE.fromBEncode kmsg
325 346
326 encodeHeaders _ kmsg = L.toStrict $ BE.encode kmsg 347 encodeHeaders _ kmsg _ = L.toStrict $ BE.encode kmsg
327 encodePayload msg = fmap BE.toBEncode msg 348 encodePayload msg = fmap BE.toBEncode msg
328 349
329-- | KRPC 'compact list' compatible encoding: contact information for 350-- | KRPC 'compact list' compatible encoding: contact information for
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs
index f666b951..8d2f9289 100644
--- a/src/Network/DatagramServer/Tox.hs
+++ b/src/Network/DatagramServer/Tox.hs
@@ -11,10 +11,13 @@
11{-# LANGUAGE TupleSections #-} 11{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE TypeFamilies #-} 12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UnboxedTuples #-} 13{-# LANGUAGE UnboxedTuples #-}
14{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE RankNTypes #-}
14module Network.DatagramServer.Tox where 16module Network.DatagramServer.Tox where
15 17
16import Data.Bits 18import Data.Bits
17import Data.ByteString (ByteString) 19import Data.ByteString (ByteString)
20import Data.ByteArray as BA (ByteArrayAccess,length,withByteArray)
18import qualified Data.Serialize as S 21import qualified Data.Serialize as S
19-- import qualified Data.ByteString.Lazy as L 22-- import qualified Data.ByteString.Lazy as L
20import qualified Data.ByteString.Char8 as Char8 23import qualified Data.ByteString.Char8 as Char8
@@ -23,12 +26,25 @@ import Data.Word
23import Data.LargeWord 26import Data.LargeWord
24import Data.IP 27import Data.IP
25import Data.Serialize 28import Data.Serialize
26-- import Network.Address (NodeInfo(..)) -- Serialize IP 29import Network.Address
27import GHC.Generics (Generic) 30import GHC.Generics (Generic)
28import Network.Socket 31import Network.Socket
29import Network.DatagramServer.Types 32import Network.DatagramServer.Types
30import qualified Network.DatagramServer.Types as Envelope (NodeId) 33import qualified Network.DatagramServer.Types as Envelope (NodeId)
31import Crypto.PubKey.ECC.Types 34import Crypto.PubKey.ECC.Types
35import Crypto.PubKey.Curve25519
36import Crypto.ECC.Class
37import qualified Crypto.Cipher.XSalsa as Salsa20
38import Data.LargeWord
39import Foreign.Ptr
40import Foreign.Storable
41import Foreign.Marshal.Alloc
42import Data.Typeable
43import StaticAssert
44import Crypto.Error.Types
45import Data.Hashable
46import Text.PrettyPrint as PP hiding ((<>))
47import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
32 48
33 49
34type Key32 = Word256 -- 32 byte key 50type Key32 = Word256 -- 32 byte key
@@ -203,7 +219,9 @@ instance Serialize NodeFormat where
203-- [Sendback data, length=8 bytes] 219-- [Sendback data, length=8 bytes]
204-- ] 220-- ]
205 221
206data ToxCipherContext = ToxCipherContext -- TODO 222data ToxCipherContext = ToxCipherContext
223 { dhtSecretKey :: SecretKey
224 }
207 225
208newtype Ciphered = Ciphered { cipheredBytes :: ByteString } 226newtype Ciphered = Ciphered { cipheredBytes :: ByteString }
209 227
@@ -227,29 +245,51 @@ putMessage (Message {..}) = do
227 let Ciphered bs = msgPayload 245 let Ciphered bs = msgPayload
228 putByteString bs 246 putByteString bs
229 247
248id2key :: NodeId Message -> PublicKey
249id2key recipient = case publicKey recipient of
250 CryptoPassed key -> key
251 CryptoFailed e -> error ("id2key: "++show e)
252
253lookupSecret :: ToxCipherContext -> NodeId Message -> TransactionID Message -> Salsa20.State
254lookupSecret ctx recipient nonce = Salsa20.initialize 20 key nonce
255 where
256 key = ecdh (Proxy :: Proxy Curve_X25519) (dhtSecretKey ctx) (id2key recipient) -- ByteArrayAccess b => b
257
230decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString) 258decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString)
231decipher = error "TODO TOX: decipher" 259decipher ctx ciphered = Right (fst . Salsa20.combine st . cipheredBytes <$> ciphered)
260 where
261 st = lookupSecret ctx (msgClient ciphered) (msgNonce ciphered)
232 262
233encipher :: ToxCipherContext -> Message ByteString -> Message Ciphered 263encipher :: ToxCipherContext -> NodeId Message -> Message ByteString -> Message Ciphered
234encipher = error "TODO TOX: encipher" 264encipher ctx recipient plain = Ciphered . fst . Salsa20.combine st <$> plain
265 where
266 st = lookupSecret ctx recipient (msgNonce plain)
235 267
236-- see rfc7748 268-- see rfc7748
269--
270-- Crypto.ECC
271-- Crypto.PubKey.Curve25519
272-- Crypto.Cipher.XSalsa
273--
237curve25519 :: Curve 274curve25519 :: Curve
238curve25519 = CurveFP (CurvePrime prime curvecommon) 275curve25519 = CurveFP (CurvePrime prime curvecommon)
239 where 276 where
240 prime = 2^255 - 19 -- (≅ 1 modulo 4) 277 prime = 2^255 - 19 -- (≅ 1 modulo 4)
241 278
279 sqrt_of_39420360 = 14781619447589544791020593568409986887264606134616475288964881837755586237401
280
242 -- 1 * v^2 = u^3 + 486662*u^2 + u 281 -- 1 * v^2 = u^3 + 486662*u^2 + u
243 282
244 curvecommon = CurveCommon 283 curvecommon = CurveCommon
245 { ecc_a = 486662 284 { ecc_a = 486662
246 , ecc_b = 1 285 , ecc_b = 1
247 , ecc_g = Point 9 14781619447589544791020593568409986887264606134616475288964881837755586237401 -- base point 286 , ecc_g = Point 9 sqrt_of_39420360 -- base point
248 , ecc_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order 287 , ecc_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order
249 , ecc_h = 8 -- cofactor 288 , ecc_h = 8 -- cofactor
250 } 289 }
251 290
252 291-- crypto_box uses xsalsa20 symmetric encryption and poly1305 authentication.
292-- https://en.wikipedia.org/wiki/Poly1305
253 293
254instance Envelope Message where 294instance Envelope Message where
255 newtype TransactionID Message = TID Nonce24 295 newtype TransactionID Message = TID Nonce24
@@ -263,6 +303,11 @@ instance Envelope Message where
263 newtype QueryExtra Message = QueryNonce { qryNonce :: Nonce8 } 303 newtype QueryExtra Message = QueryNonce { qryNonce :: Nonce8 }
264 newtype ResponseExtra Message = ResponseNonce { rspNonce :: Nonce8 } 304 newtype ResponseExtra Message = ResponseNonce { rspNonce :: Nonce8 }
265 305
306 data PacketDestination Message = ToxAddr { toxID :: NodeId Message
307 , toxSockAddr :: SockAddr
308 }
309 deriving (Eq,Ord,Show)
310
266 envelopePayload = msgPayload 311 envelopePayload = msgPayload
267 312
268 envelopeTransaction = msgNonce 313 envelopeTransaction = msgNonce
@@ -272,15 +317,70 @@ instance Envelope Message where
272 envelopeClass Message { msgType = GetNodes } = Query GetNodes 317 envelopeClass Message { msgType = GetNodes } = Query GetNodes
273 envelopeClass Message { msgType = SendNodes } = Response Nothing 318 envelopeClass Message { msgType = SendNodes } = Response Nothing
274 319
320 makeAddress qry = ToxAddr (either id msgClient qry)
321
275 buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self } 322 buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }
276 323
277 -- buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a) 324 -- buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a)
278 -- buildQuery nid addr meth tid q = todo 325 buildQuery nid addr meth tid q = return $ Message
326 { msgType = meth
327 , msgClient = nid
328 , msgNonce = tid
329 , msgPayload = q
330 }
279 331
280 uniqueTransactionId cnt = do 332 uniqueTransactionId cnt = do
281 return $ either (error "failed to create TransactionId") TID 333 return $ either (error "failed to create TransactionId") TID
282 $ S.decode $ Char8.pack (take 24 $ show cnt ++ repeat ' ') 334 $ S.decode $ Char8.pack (take 24 $ show cnt ++ repeat ' ')
283 335
336
337staticAssert isLittleEndian -- assumed by 'withWord64Ptr'
338
339with3Word64Ptr :: Nonce24 -> (Ptr Word64 -> IO a) -> IO a
340with3Word64Ptr (LargeKey wlo (LargeKey wmid whi)) kont =
341 allocaBytes (sizeOf wlo * 3) $ \p -> do
342 pokeElemOff p 0 wlo
343 pokeElemOff p 1 wmid
344 pokeElemOff p 2 whi
345 kont p
346
347with4Word64Ptr :: Key32 -> (Ptr Word64 -> IO a) -> IO a
348with4Word64Ptr (LargeKey wlo (LargeKey wmid (LargeKey whi whighest))) kont =
349 allocaBytes (sizeOf wlo * 4) $ \p -> do
350 pokeElemOff p 0 wlo
351 pokeElemOff p 1 wmid
352 pokeElemOff p 2 whi
353 pokeElemOff p 3 whighest
354 kont p
355
356
357instance ByteArrayAccess (TransactionID Message) where
358 length _ = 24
359 withByteArray (TID nonce) kont = with3Word64Ptr nonce (kont . castPtr)
360
361instance ByteArrayAccess (NodeId Message) where
362 length _ = 32
363 withByteArray (NodeId nonce) kont = with4Word64Ptr nonce (kont . castPtr)
364
365
366instance Hashable (NodeId Message) where
367 hashWithSalt s (NodeId (LargeKey a (LargeKey b (LargeKey c d)))) =
368 hashWithSalt s (a,b,c,d)
369
370instance Hashable (PacketDestination Message) where
371 hashWithSalt s (ToxAddr nid addr) = hashWithSalt s nid
372
373instance Serialize (PacketDestination Message) where
374 put (ToxAddr (NodeId nid) addr) = put nid >> putSockAddr addr
375 get = ToxAddr <$> (NodeId <$> get) <*> getSockAddr
376
377instance Pretty (PacketDestination Message) where
378 pPrint = PP.text . show
379
380instance Address (PacketDestination Message) where
381 toSockAddr (ToxAddr _ addr) = addr
382 fromSockAddr _ = Nothing
383
284instance WireFormat ByteString Message where 384instance WireFormat ByteString Message where
285 type SerializableTo ByteString = Serialize 385 type SerializableTo ByteString = Serialize
286 type CipherContext ByteString Message = ToxCipherContext 386 type CipherContext ByteString Message = ToxCipherContext
@@ -289,6 +389,6 @@ instance WireFormat ByteString Message where
289 encodePayload = fmap encode 389 encodePayload = fmap encode
290 390
291 decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx 391 decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
292 encodeHeaders ctx msg = runPut $ putMessage $ encipher ctx msg 392 encodeHeaders ctx msg recipient = runPut $ putMessage $ encipher ctx (toxID recipient) msg
293 393
294instance Read (NodeId Message) where readsPrec d s = map (\(w,xs) -> (NodeId w, xs)) $ decodeHex s 394instance Read (NodeId Message) where readsPrec d s = map (\(w,xs) -> (NodeId w, xs)) $ decodeHex s
diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs
index 13f79afb..14968764 100644
--- a/src/Network/DatagramServer/Types.hs
+++ b/src/Network/DatagramServer/Types.hs
@@ -96,11 +96,21 @@ class Envelope envelope where
96 data NodeId envelope 96 data NodeId envelope
97 data QueryExtra envelope 97 data QueryExtra envelope
98 data ResponseExtra envelope 98 data ResponseExtra envelope
99 data PacketDestination envelope
99 100
100 envelopePayload :: envelope a -> a 101 envelopePayload :: envelope a -> a
101 envelopeTransaction :: envelope a -> TransactionID envelope 102 envelopeTransaction :: envelope a -> TransactionID envelope
102 envelopeClass :: envelope a -> MessageClass envelope 103 envelopeClass :: envelope a -> MessageClass envelope
103 104
105 -- | > replyAddress qry addr
106 --
107 -- [ qry ] received query message
108 --
109 -- [ addr ] SockAddr of query origin
110 --
111 -- Returns: Destination address for reply.
112 makeAddress :: Either (NodeId envelope) (envelope a) -> SockAddr -> PacketDestination envelope
113
104 -- | > buildReply self addr qry response 114 -- | > buildReply self addr qry response
105 -- 115 --
106 -- [ self ] this node's id. 116 -- [ self ] this node's id.
@@ -320,8 +330,7 @@ genBucketSample' gen self (q,m,b)
320 h = xor b (complement m .&. BS.last hd) 330 h = xor b (complement m .&. BS.last hd)
321 t = m .&. BS.head tl 331 t = m .&. BS.head tl
322 332
323 333class (Envelope envelope, Address (PacketDestination envelope)) => WireFormat raw envelope where
324class Envelope envelope => WireFormat raw envelope where
325 type SerializableTo raw :: * -> Constraint 334 type SerializableTo raw :: * -> Constraint
326 type CipherContext raw envelope 335 type CipherContext raw envelope
327 336
@@ -336,7 +345,7 @@ class Envelope envelope => WireFormat raw envelope where
336 decodeHeaders :: CipherContext raw envelope -> raw -> Either String (envelope raw) 345 decodeHeaders :: CipherContext raw envelope -> raw -> Either String (envelope raw)
337 decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a) 346 decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a)
338 347
339 encodeHeaders :: CipherContext raw envelope -> envelope raw -> ByteString 348 encodeHeaders :: CipherContext raw envelope -> envelope raw -> PacketDestination envelope -> ByteString
340 encodePayload :: SerializableTo raw a => envelope a -> envelope raw 349 encodePayload :: SerializableTo raw a => envelope a -> envelope raw
341 350
342encodeHexDoc :: Serialize x => x -> Doc 351encodeHexDoc :: Serialize x => x -> Doc
@@ -359,3 +368,21 @@ instance (Pretty ip, Pretty (NodeId dht)) => Pretty [NodeInfo dht ip u] where
359 pPrint = PP.vcat . PP.punctuate "," . map pPrint 368 pPrint = PP.vcat . PP.punctuate "," . map pPrint
360 369
361 370
371
372putSockAddr (SockAddrInet port addr)
373 = put (0x34 :: Word8) >> put port >> put addr
374putSockAddr (SockAddrInet6 port flow addr scope)
375 = put (0x36 :: Word8) >> put port >> put addr >> put scope >> put flow
376putSockAddr (SockAddrUnix path)
377 = put (0x75 :: Word8) >> put path
378putSockAddr (SockAddrCan num)
379 = put (0x63 :: Word8) >> put num
380
381getSockAddr = do
382 c <- get
383 case c :: Word8 of
384 0x34 -> SockAddrInet <$> get <*> get
385 0x36 -> (\p a s f -> SockAddrInet6 p f a s) <$> get <*> get <*> get <*> get
386 0x75 -> SockAddrUnix <$> get
387 0x63 -> SockAddrCan <$> get
388 _ -> fail "getSockAddr"
diff --git a/src/StaticAssert.hs b/src/StaticAssert.hs
new file mode 100644
index 00000000..d0784c97
--- /dev/null
+++ b/src/StaticAssert.hs
@@ -0,0 +1,13 @@
1module StaticAssert where
2
3import Network.Socket (htonl)
4import Language.Haskell.TH
5
6staticAssert :: Bool -> Q [Dec]
7staticAssert cond = case cond of
8 True -> return []
9 False -> fail "staticAssert failed"
10
11isLittleEndian :: Bool
12isLittleEndian = htonl 0x01000000 == 1
13
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 18:20:36 +0000