diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,163 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and +distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the +copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other +entities that control, are controlled by, or are under common control with +that entity. For the purposes of this definition, "control" means (i) the +power, direct or indirect, to cause the direction or management of such +entity, whether by contract or otherwise, or (ii) ownership of fifty percent +(50%) or more of the outstanding shares, or (iii) beneficial ownership of such +entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising +permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, +including but not limited to software source code, documentation source, and +configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or +translation of a Source form, including but not limited to compiled object +code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, +made available under the License, as indicated by a copyright notice that is +included in or attached to the work (an example is provided in the Appendix +below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that +is based on (or derived from) the Work and for which the editorial revisions, +annotations, elaborations, or other modifications represent, as a whole, an +original work of authorship. For the purposes of this License, Derivative +Works shall not include works that remain separable from, or merely link (or +bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original +version of the Work and any modifications or additions to that Work or +Derivative Works thereof, that is intentionally submitted to Licensor for +inclusion in the Work by the copyright owner or by an individual or Legal +Entity authorized to submit on behalf of the copyright owner. For the purposes +of this definition, "submitted" means any form of electronic, verbal, or +written communication sent to the Licensor or its representatives, including +but not limited to communication on electronic mailing lists, source code +control systems, and issue tracking systems that are managed by, or on behalf +of, the Licensor for the purpose of discussing and improving the Work, but +excluding communication that is conspicuously marked or otherwise designated +in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf +of whom a Contribution has been received by Licensor and subsequently +incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this +License, each Contributor hereby grants to You a perpetual, worldwide, +non-exclusive, no-charge, royalty-free, irrevocable copyright license to +reproduce, prepare Derivative Works of, publicly display, publicly perform, +sublicense, and distribute the Work and such Derivative Works in Source or +Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this +License, each Contributor hereby grants to You a perpetual, worldwide, +non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this +section) patent license to make, have made, use, offer to sell, sell, import, +and otherwise transfer the Work, where such license applies only to those +patent claims licensable by such Contributor that are necessarily infringed by +their Contribution(s) alone or by combination of their Contribution(s) with +the Work to which such Contribution(s) was submitted. If You institute patent +litigation against any entity (including a cross-claim or counterclaim in a +lawsuit) alleging that the Work or a Contribution incorporated within the Work +constitutes direct or contributory patent infringement, then any patent +licenses granted to You under this License for that Work shall terminate as of +the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or +Derivative Works thereof in any medium, with or without modifications, and in +Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of +this License; and + +You must cause any modified files to carry prominent notices stating that You +changed the files; and + +You must retain, in the Source form of any Derivative Works that You +distribute, all copyright, patent, trademark, and attribution notices from the +Source form of the Work, excluding those notices that do not pertain to any +part of the Derivative Works; and + +If the Work includes a "NOTICE" text file as part of its distribution, then +any Derivative Works that You distribute must include a readable copy of the +attribution notices contained within such NOTICE file, excluding those notices +that do not pertain to any part of the Derivative Works, in at least one of +the following places: within a NOTICE text file distributed as part of the +Derivative Works; within the Source form or documentation, if provided along +with the Derivative Works; or, within a display generated by the Derivative +Works, if and wherever such third-party notices normally appear. The contents +of the NOTICE file are for informational purposes only and do not modify the +License. You may add Your own attribution notices within Derivative Works that +You distribute, alongside or as an addendum to the NOTICE text from the Work, +provided that such additional attribution notices cannot be construed as +modifying the License. + +You may add Your own copyright statement to Your modifications and may provide +additional or different license terms and conditions for use, reproduction, or +distribution of Your modifications, or for any such Derivative Works as a +whole, provided Your use, reproduction, and distribution of the Work otherwise +complies with the conditions stated in this License. + +5. Submission of Contributions. Unless You explicitly state otherwise, any +Contribution intentionally submitted for inclusion in the Work by You to the +Licensor shall be under the terms and conditions of this License, without any +additional terms or conditions. Notwithstanding the above, nothing herein +shall supersede or modify the terms of any separate license agreement you may +have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, +trademarks, service marks, or product names of the Licensor, except as +required for reasonable and customary use in describing the origin of the Work +and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in +writing, Licensor provides the Work (and each Contributor provides its +Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +KIND, either express or implied, including, without limitation, any warranties +or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A +PARTICULAR PURPOSE. You are solely responsible for determining the +appropriateness of using or redistributing the Work and assume any risks +associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in +tort (including negligence), contract, or otherwise, unless required by +applicable law (such as deliberate and grossly negligent acts) or agreed to in +writing, shall any Contributor be liable to You for damages, including any +direct, indirect, special, incidental, or consequential damages of any +character arising as a result of this License or out of the use or inability +to use the Work (including but not limited to damages for loss of goodwill, +work stoppage, computer failure or malfunction, or any and all other +commercial damages or losses), even if such Contributor has been advised of +the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work +or Derivative Works thereof, You may choose to offer, and charge a fee for, +acceptance of support, warranty, indemnity, or other liability obligations +and/or rights consistent with this License. However, in accepting such +obligations, You may act only on Your own behalf and on Your sole +responsibility, not on behalf of any other Contributor, and only if You agree +to indemnify, defend, and hold each Contributor harmless for any liability +incurred by, or claims asserted against, such Contributor by reason of your +accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cmd/interop-entrypoint/Main.hs b/cmd/interop-entrypoint/Main.hs new file mode 100644 --- /dev/null +++ b/cmd/interop-entrypoint/Main.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Entrypoint for testing interoperability. +-- +-- Interoperability harness lives at +-- +-- Any entry point for the harness needs to: +-- - take everything it needs as command-line parameters +-- - print the outbound message to stdout, base16-encoded +-- - read the inbound message from stdin, base16-encoded +-- - print the session key, base16-encoded +-- - terminate +-- +-- Much of the code in here will probably move to the library as we figure out +-- what we need to do to implement the protocol properly. + +module Main (main) where + +import Protolude hiding (group) + +import Crypto.Hash (SHA256(..)) +import qualified Data.ByteString.Base16 as Base16 +import Options.Applicative +import System.IO (hFlush, hGetLine, hPutStrLn) + +import qualified Crypto.Spake2 as Spake2 +import Crypto.Spake2 + ( Password + , Protocol + , SideID(..) + , makeSymmetricProtocol + , makeAsymmetricProtocol + , createSessionKey + , makePassword + , computeOutboundMessage + , generateKeyMaterial + , extractElement + , startSpake2 + , elementToMessage + , formatError + ) +import Crypto.Spake2.Group (Group(..)) +import Crypto.Spake2.Groups (Ed25519(..)) + + +data Config = Config Side Password deriving (Eq, Ord) + +data Side = SideA | SideB | Symmetric deriving (Eq, Ord, Show) + +configParser :: Parser Config +configParser = + Config + <$> argument sideParser (metavar "SIDE") + <*> argument passwordParser (metavar "PASSWORD") + where + sideParser = eitherReader $ \s -> + case s of + "A" -> pure SideA + "B" -> pure SideB + "Symmetric" -> pure Symmetric + unknown -> throwError $ "Unrecognized side: " <> unknown + passwordParser = makePassword . toS <$> str + + +-- | Terminate the test with a failure, printing a message to stderr. +abort :: HasCallStack => Text -> IO () +abort message = do + hPutStrLn stderr $ toS ("ERROR: " <> message) + exitWith (ExitFailure 1) + + +runInteropTest + :: (HasCallStack, Group group) + => Protocol group SHA256 + -> Password + -> Handle + -> Handle + -> IO () +runInteropTest protocol password inH outH = do + spake2 <- startSpake2 protocol password + let outElement = computeOutboundMessage spake2 + output (elementToMessage protocol outElement) + line <- hGetLine inH + let inMsg = parseHex (toS line) + case inMsg of + Left err -> abort err + Right inMsgBytes -> + case extractElement protocol inMsgBytes of + Left err -> abort $ "Could not handle incoming message (line = " <> show line <> ", msgBytes = " <> show inMsgBytes <> "): " <> formatError err + Right inElement -> do + -- TODO: This is wrong, because it doesn't handle A/B properly. + let key = generateKeyMaterial spake2 inElement + let sessionKey = createSessionKey protocol inElement outElement key password + output sessionKey + + where + output message = do + hPutStrLn outH (toS (Base16.encode message)) + hFlush outH + + parseHex line = + case Base16.decode line of + (bytes, "") -> Right bytes + _ -> Left ("Could not decode line: " <> show line) + + +makeProtocolFromSide :: Side -> Protocol Ed25519 SHA256 +makeProtocolFromSide side = + case side of + SideA -> makeAsymmetricProtocol hashAlg group m n idA idB Spake2.SideA + SideB -> makeAsymmetricProtocol hashAlg group m n idA idB Spake2.SideB + Symmetric -> makeSymmetricProtocol hashAlg group s idSymmetric + where + hashAlg = SHA256 + group = Ed25519 + m = arbitraryElement group ("M" :: ByteString) + n = arbitraryElement group ("N" :: ByteString) + s = arbitraryElement group ("S" :: ByteString) + idA = SideID "" + idB = SideID "" + idSymmetric = SideID "" + +main :: IO () +main = do + Config side password <- execParser opts + let protocol = makeProtocolFromSide side + runInteropTest protocol password stdin stdout + exitSuccess + where + opts = info (helper <*> configParser) + (fullDesc <> + header "interop-entrypoint - tool to help test SPAKE2 interop") diff --git a/spake2.cabal b/spake2.cabal new file mode 100644 --- /dev/null +++ b/spake2.cabal @@ -0,0 +1,80 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: spake2 +version: 0.1.0 +synopsis: Implementation of the SPAKE2 Password-Authenticated Key Exchange algorithm +description: This library implements the SPAKE2 password-authenticated key exchange + ("PAKE") algorithm. This allows two parties, who share a weak password, to + safely derive a strong shared secret (and therefore build an + encrypted+authenticated channel). +category: Crypto +homepage: https://github.com/jml/haskell-spake2#readme +bug-reports: https://github.com/jml/haskell-spake2/issues +maintainer: Jonathan M. Lange +license: Apache +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jml/haskell-spake2 + +library + hs-source-dirs: + src + default-extensions: NoImplicitPrelude OverloadedStrings + ghc-options: -Wall -Wno-type-defaults + build-depends: + base >= 4.9 && < 5 + , protolude + , bytestring + , cryptonite + , memory + exposed-modules: + Crypto.Spake2 + Crypto.Spake2.Group + Crypto.Spake2.Groups + Crypto.Spake2.Groups.Ed25519 + Crypto.Spake2.Groups.IntegerAddition + Crypto.Spake2.Groups.IntegerGroup + Crypto.Spake2.Math + Crypto.Spake2.Util + default-language: Haskell2010 + +executable haskell-spake2-interop-entrypoint + main-is: Main.hs + hs-source-dirs: + cmd/interop-entrypoint + default-extensions: NoImplicitPrelude OverloadedStrings + ghc-options: -Wall -Wno-type-defaults -threaded + build-depends: + base >= 4.9 && < 5 + , protolude + , base16-bytestring + , cryptonite + , optparse-applicative + , spake2 + default-language: Haskell2010 + +test-suite tasty + type: exitcode-stdio-1.0 + main-is: Tasty.hs + hs-source-dirs: + tests + default-extensions: NoImplicitPrelude OverloadedStrings + ghc-options: -Wall -Wno-type-defaults + build-depends: + base >= 4.9 && < 5 + , protolude + , cryptonite + , QuickCheck + , spake2 + , tasty + , tasty-hspec + other-modules: + Groups + Spake2 + default-language: Haskell2010 diff --git a/src/Crypto/Spake2.hs b/src/Crypto/Spake2.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NamedFieldPuns #-} + +{-| +Module: Crypto.Spake2 +Description: Implementation of SPAKE2 key exchange protocol + +Say that you and someone else share a secret password, and you want to use +this password to arrange some secure channel of communication. You want: + + * to know that the other party also knows the secret password (maybe + they're an imposter!) + * the password to be secure against offline dictionary attacks + * probably some other things + +SPAKE2 is an algorithm for agreeing on a key exchange that meets these +criteria. See [Simple Password-Based Encrypted Key Exchange +Protocols](http://www.di.ens.fr/~pointche/Documents/Papers/2005_rsa.pdf) by +Michel Abdalla and David Pointcheval for more details. + +== How it works + +=== Preliminaries + +Before exchanging, two nodes need to agree on the following, out-of-band: + +In general: + +* hash algorithm, \(H\) +* group to use, \(G\) +* arbitrary members of group to use for blinding +* a means of converting this password to a scalar of group + +For a specific exchange: + +* whether the connection is symmetric or asymmetric +* the IDs of the respective sides +* a shared, secret password in bytes + +#protocol# + +=== Protocol + +==== How we map the password to a scalar + +Use HKDF expansion (see 'expandData') to expand the password by 16 bytes, +using an empty salt, and "SPAKE2 pw" as the info. + +Then, use a group-specific mapping from bytes to scalars. +Since scalars are normally isomorphic to integers, +this will normally be a matter of converting the bytes to an integer +using standard deserialization +and then turning the integer into a scalar. + +==== How we exchange information + +See 'Crypto.Spake2.Math' for details on the mathematics of the exchange. + +==== How python-spake2 works + +- Message to other side is prepended with a single character, @A@, @B@, or + @S@, to indicate which side it came from +- The hash function for generating the session key has a few interesting properties: + - uses SHA256 for hashing + - does not include password or IDs directly, but rather uses /their/ SHA256 + digests as inputs to the hash + - for the symmetric version, it sorts \(X^{\star}\) and \(Y^{\star}\), + because neither side knows which is which +- By default, the ID of either side is the empty bytestring + +== Open questions + +* how does endianness come into play? +* what is Shallue-Woestijne-Ulas and why is it relevant? + +== References + +* [Javascript implementation](https://github.com/bitwiseshiftleft/sjcl/pull/273/), includes long, possibly relevant discussion +* [Python implementation](https://github.com/warner/python-spake2) +* [SPAKE2 random elements](http://www.lothar.com/blog/54-spake2-random-elements/) - blog post by warner about choosing \(M\) and \(N\) +* [Simple Password-Based Encrypted Key Exchange Protocols](http://www.di.ens.fr/~pointche/Documents/Papers/2005_rsa.pdf) by Michel Abdalla and David Pointcheval +* [draft-irtf-cfrg-spake2-03](https://tools.ietf.org/html/draft-irtf-cfrg-spake2-03) - expired IRTF draft for SPAKE2 + +-} + +module Crypto.Spake2 + ( something + , Password + , makePassword + -- * The SPAKE2 protocol + , Protocol + , makeAsymmetricProtocol + , makeSymmetricProtocol + , startSpake2 + , Math.computeOutboundMessage + , Math.generateKeyMaterial + , extractElement + , MessageError + , formatError + , elementToMessage + , createSessionKey + , SideID(..) + , WhichSide(..) + ) where + +import Protolude hiding (group) + +import Crypto.Error (CryptoError, CryptoFailable(..)) +import Crypto.Hash (HashAlgorithm, hashWith) +import Crypto.Random.Types (MonadRandom(..)) +import Data.ByteArray (ByteArrayAccess, ByteArray) +import qualified Data.ByteArray as ByteArray +import qualified Data.ByteString as ByteString + +import Crypto.Spake2.Group (Group(..), decodeScalar, scalarSizeBytes) +import qualified Crypto.Spake2.Math as Math +import Crypto.Spake2.Util (expandData) + + +-- | Do-nothing function so that we have something to import in our tests. +-- TODO: Actually test something genuine and then remove this. +something :: a -> a +something x = x + +-- | Shared secret password used to negotiate the connection. +-- +-- Constructor deliberately not exported, +-- so that once a 'Password' has been created, the actual password cannot be retrieved by other modules. +-- +-- Construct with 'makePassword'. +newtype Password = Password ByteString deriving (Eq, Ord) + +-- | Construct a password. +makePassword :: ByteString -> Password +makePassword = Password + +-- | Bytes that identify a side of the protocol +newtype SideID = SideID { unSideID :: ByteString } deriving (Eq, Ord, Show) + +-- | Convert a user-supplied password into a scalar on a group. +passwordToScalar :: Group group => group -> Password -> Scalar group +passwordToScalar group password = + let oversized = expandPassword password (scalarSizeBytes group + 16) :: ByteString + in decodeScalar group oversized + +-- | Expand a password using HKDF so that it has a certain number of bytes. +-- +-- TODO: jml cannot remember why you might want to call this. +expandPassword :: ByteArray output => Password -> Int -> output +expandPassword (Password bytes) numBytes = expandData info bytes numBytes + where + -- This needs to be exactly "SPAKE2 pw" + -- See + info = "SPAKE2 pw" + +-- | Turn an element into a message from this side of the protocol. +elementToMessage :: Group group => Protocol group hashAlgorithm -> Element group -> ByteString +elementToMessage protocol element = prefix <> encodeElement (group protocol) element + where + prefix = + case relation protocol of + Symmetric _ -> "S" + Asymmetric{us=SideA} -> "A" + Asymmetric{us=SideB} -> "B" + +-- | An error that occurs when interpreting messages from the other side of the exchange. +data MessageError + = EmptyMessage -- ^ We received an empty bytestring. + | UnexpectedPrefix Word8 Word8 + -- ^ The bytestring had an unexpected prefix. + -- We expect the prefix to be @A@ if the other side is side A, + -- @B@ if they are side B, + -- or @S@ if the connection is symmetric. + -- First argument is received prefix, second is expected. + | BadCrypto CryptoError ByteString + -- ^ Message could not be decoded to an element of the group. + -- This can indicate either an error in serialization logic, + -- or in mathematics. + deriving (Eq, Show) + +-- | Turn a 'MessageError' into human-readable text. +formatError :: MessageError -> Text +formatError EmptyMessage = "Other side sent us an empty message" +formatError (UnexpectedPrefix got expected) = "Other side claims to be " <> show (chr (fromIntegral got)) <> ", expected " <> show (chr (fromIntegral expected)) +formatError (BadCrypto err message) = "Could not decode message (" <> show message <> ") to element: " <> show err + +-- | Extract an element on the group from an incoming message. +-- +-- Returns a 'MessageError' if we cannot decode the message, +-- or the other side does not appear to be the expected other side. +-- +-- TODO: Need to protect against reflection attack at some point. +extractElement :: Group group => Protocol group hashAlgorithm -> ByteString -> Either MessageError (Element group) +extractElement protocol message = + case ByteString.uncons message of + Nothing -> throwError EmptyMessage + Just (prefix, msg) + | prefix /= theirPrefix (relation protocol) -> throwError $ UnexpectedPrefix prefix (theirPrefix (relation protocol)) + | otherwise -> + case decodeElement (group protocol) msg of + CryptoFailed err -> throwError (BadCrypto err msg) + CryptoPassed element -> pure element + + +-- | One side of the SPAKE2 protocol. +data Side group + = Side + { sideID :: SideID -- ^ Bytes identifying this side + , blind :: Element group -- ^ Arbitrarily chosen element in the group + -- used by this side to blind outgoing messages. + } + +-- | Which side we are. +data WhichSide = SideA | SideB deriving (Eq, Ord, Show, Bounded, Enum) + +-- | Relation between two sides in SPAKE2. +-- Can be either symmetric (both sides are the same), or asymmetric. +-- +-- XXX: Maybe too generic? Could reasonably replace 'a' with 'Side group'. +data Relation a + = Asymmetric + { sideA :: a -- ^ Side A. Both sides need to agree who side A is. + , sideB :: a -- ^ Side B. Both sides need to agree who side B is. + , us :: WhichSide -- ^ Which side we are + } + | Symmetric + { bothSides :: a -- ^ Description used by both sides. + } + +theirPrefix :: Relation a -> Word8 +theirPrefix relation = + fromIntegral . ord $ case relation of + Asymmetric{us=SideA} -> 'B' + Asymmetric{us=SideB} -> 'A' + Symmetric{} -> 'S' + +-- | Everything required for the SPAKE2 protocol. +-- +-- Both sides must agree on these values for the protocol to work. +-- This /mostly/ means value equality, except for 'Relation.us', +-- where each side must have complementary values. +-- +-- Construct with 'makeAsymmetricProtocol' or 'makeSymmetricProtocol'. +data Protocol group hashAlgorithm + = Protocol + { group :: group -- ^ The group to use for encryption + , hashAlgorithm :: hashAlgorithm -- ^ Hash algorithm used for generating the session key + , relation :: Relation (Side group) -- ^ How the two sides relate to each other + } + +-- | Construct an asymmetric SPAKE2 protocol. +makeAsymmetricProtocol :: hashAlgorithm -> group -> Element group -> Element group -> SideID -> SideID -> WhichSide -> Protocol group hashAlgorithm +makeAsymmetricProtocol hashAlgorithm group blindA blindB sideA sideB whichSide = + Protocol + { group = group + , hashAlgorithm = hashAlgorithm + , relation = Asymmetric + { sideA = Side { sideID = sideA, blind = blindA } + , sideB = Side { sideID = sideB, blind = blindB } + , us = whichSide + } + } + +-- | Construct a symmetric SPAKE2 protocol. +makeSymmetricProtocol :: hashAlgorithm -> group -> Element group -> SideID -> Protocol group hashAlgorithm +makeSymmetricProtocol hashAlgorithm group blind id = + Protocol + { group = group + , hashAlgorithm = hashAlgorithm + , relation = Symmetric Side { sideID = id, blind = blind } + } + +-- | Get the parameters for the mathematical part of SPAKE2 from the protocol specification. +getParams :: Protocol group hashAlgorithm -> Math.Params group +getParams Protocol{group, relation} = + case relation of + Symmetric{bothSides} -> mkParams bothSides bothSides + Asymmetric{sideA, sideB, us} -> + case us of + SideA -> mkParams sideA sideB + SideB -> mkParams sideB sideA + + where + mkParams ours theirs = + Math.Params + { Math.group = group + , Math.ourBlind = blind ours + , Math.theirBlind = blind theirs + } + +-- | Commence a SPAKE2 exchange. +startSpake2 + :: (MonadRandom randomly, Group group) + => Protocol group hashAlgorithm + -> Password + -> randomly (Math.Spake2Exchange group) +startSpake2 protocol password = + Math.startSpake2 Math.Spake2 { Math.params = getParams protocol + , Math.password = passwordToScalar (group protocol) password + } + +-- | Create a session key based on the output of SPAKE2. +-- +-- \[SK \leftarrow H(A, B, X^{\star}, Y^{\star}, K, pw)\] +-- +-- Including \(pw\) in the session key is what makes this SPAKE2, not SPAKE1. +createSessionKey + :: (Group group, HashAlgorithm hashAlgorithm) + => Protocol group hashAlgorithm -- ^ The protocol used for this exchange + -> Element group -- ^ The message from side A, \(X^{\star}\), or either side if symmetric + -> Element group -- ^ The message from side B, \(Y^{\star}\), or either side if symmetric + -> Element group -- ^ The calculated key material, \(K\) + -> Password -- ^ The shared secret password + -> ByteString -- ^ A session key to use for further communication +createSessionKey Protocol{group, hashAlgorithm, relation} x y k (Password password) = + hashDigest transcript + + where + -- The protocol expects that when we include the hash of various + -- components (e.g. the password) as input for the session key hash, + -- that we use the *byte* representation of these elements. + hashDigest :: ByteArrayAccess input => input -> ByteString + hashDigest thing = ByteArray.convert (hashWith hashAlgorithm thing) + + transcript = + case relation of + Asymmetric{sideA, sideB} -> mconcat [ hashDigest password + , hashDigest (unSideID (sideID sideA)) + , hashDigest (unSideID (sideID sideB)) + , encodeElement group x + , encodeElement group y + , encodeElement group k + ] + Symmetric{bothSides} -> mconcat [ hashDigest password + , hashDigest (unSideID (sideID bothSides)) + , symmetricElements + , encodeElement group k + ] + + symmetricElements = + let [ firstMessage, secondMessage ] = sort [ encodeElement group x, encodeElement group y ] + in firstMessage <> secondMessage diff --git a/src/Crypto/Spake2/Group.hs b/src/Crypto/Spake2/Group.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Group.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE TypeFamilies #-} +{-| +Module: Crypto.Spake2.Group +Description: Interface for mathematical groups +-} +module Crypto.Spake2.Group + ( Group(..) + , decodeScalar + , elementSizeBytes + , scalarSizeBytes + , KeyPair(..) + ) where + +import Protolude hiding (group, length) + +import Crypto.Error (CryptoFailable(..)) +import Crypto.Random.Types (MonadRandom(..)) +import Data.ByteArray (ByteArray, ByteArrayAccess(..)) + +import Crypto.Spake2.Util (bytesToNumber) + +-- | A mathematical group intended to be used with SPAKE2. +-- +-- Notes: +-- +-- * This is a much richer interface than one would expect from a group purely derived from abstract algebra +-- * jml thinks this is relevant to all Diffie-Hellman cryptography, +-- but too ignorant to say for sure +-- * Is this group automatically abelian? cyclic? +-- Must it have these properties? +class Group group where + -- | An element of the group. + type Element group :: * + + -- | A scalar for this group. + -- Mathematically equivalent to an integer, + -- but possibly stored differently for computational reasons. + type Scalar group :: * + + -- | Group addition. + -- + -- prop> \x y z -> elementAdd group (elementAdd group x y) z == elementAdd group x (elementAdd group y z) + elementAdd :: group -> Element group -> Element group -> Element group + + -- | Inverse with respect to group addition. + -- + -- prop> \x -> (elementAdd group x (elementNegate group x)) == groupIdentity + -- prop> \x -> (elementNegate group (elementNegate group x)) == x + elementNegate :: group -> Element group -> Element group + + -- | Subtract one element from another. + -- + -- prop> \x y -> (elementSubtract group x y) == (elementAdd group x (elementNegate group y)) + elementSubtract :: group -> Element group -> Element group -> Element group + elementSubtract group x y = elementAdd group x (elementNegate group y) + + -- | Identity of the group. + -- + -- Note [Added for completeness] + -- + -- prop> \x -> (elementAdd group x groupIdentity) == x + -- prop> \x -> (elementAdd group groupIdentity x) == x + groupIdentity :: group -> Element group + + -- | Multiply an element of the group with respect to a scalar. + -- + -- This is equivalent to adding the element to itself N times, where N is a scalar. + scalarMultiply :: group -> Scalar group -> Element group -> Element group + + -- | Get the scalar that corresponds to an integer. + -- + -- Note [Added for completeness] + -- + -- prop> \x -> scalarToInteger group (integerToScalar group x) == x + integerToScalar :: group -> Integer -> Scalar group + + -- | Get the integer that corresponds to a scalar. + -- + -- Note [Added for completeness] + -- + -- prop> \x -> integerToScalar group (scalarToInteger group x) == x + scalarToInteger :: group -> Scalar group -> Integer + + -- | Encode an element of the group into bytes. + -- + -- Note [Byte encoding in Group] + -- + -- prop> \x -> decodeElement group (encodeElement group x) == CryptoPassed x + encodeElement :: ByteArray bytes => group -> Element group -> bytes + + -- | Decode an element into the group from some bytes. + -- + -- Note [Byte encoding in Group] + decodeElement :: ByteArray bytes => group -> bytes -> CryptoFailable (Element group) + + -- | Encode a scalar into bytes. + -- | Generate a new random element of the group, with corresponding scalar. + generateElement :: MonadRandom randomly => group -> randomly (KeyPair group) + + -- | Size of elements, in bits + elementSizeBits :: group -> Int + + -- | Size of scalars, in bits + scalarSizeBits :: group -> Int + + -- | Deterministically create an arbitrary element from a seed bytestring. + -- + -- __XXX__: jml would much rather this take a scalar, an element, or even an integer, rather than bytes + -- because bytes mean that the group instances have to know about hash algorithms and HKDF. + -- If the IntegerGroup class in SPAKE2 also oversized its input, + -- then it and the ed25519 implementation would have identical decoding. + arbitraryElement :: ByteArrayAccess bytes => group -> bytes -> Element group + + +-- | Map some arbitrary bytes into a scalar in a group. +decodeScalar :: (ByteArrayAccess bytes, Group group) => group -> bytes -> Scalar group +decodeScalar group bytes = integerToScalar group (bytesToNumber bytes) + +-- | Size of elements in a group, in bits. +elementSizeBytes :: Group group => group -> Int +elementSizeBytes group = (elementSizeBits group + 7) `div` 8 + +-- | Size of scalars in a group, in bytes. +scalarSizeBytes :: Group group => group -> Int +scalarSizeBytes group = (scalarSizeBits group + 7) `div` 8 + +-- | A group key pair composed of the private part (a scalar) +-- and a public part (associated group element). +data KeyPair group + = KeyPair + { keyPairPublic :: !(Element group) + , keyPairPrivate :: !(Scalar group) + } + +{- +Note [Byte encoding in Group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +jml is unsure whether it is a good idea to put encode/decode methods in the 'Group' typeclass. + +Reasons for: + + * cryptonite does it with 'EllipticCurve' + * warner does it with spake2.groups + +Reasons against: + + * mathematical structure of groups has no connection to serialization + * might want multiple encodings for same mathematical group + +Including for now on the assumption that I'm ignorant. + +TODO: Revisit decision to put byte encoding in Group after we've done a couple of implementations +-} + +{- +Note [Added for completeness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Several methods were added to 'Group' out of a desire for mathematical completeness +rather than necessity for implementing SPAKE2. + +These include: + + * 'groupIdentity' -- because groups have identities (just like semigroups) + * 'scalarToInteger' and 'integerToScalar' -- because scalars are mathematically integers + * 'encodeScalar' -- because having an inverse of 'decodeScalar' makes it easier to test + +-} diff --git a/src/Crypto/Spake2/Groups.hs b/src/Crypto/Spake2/Groups.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Groups.hs @@ -0,0 +1,18 @@ +{-| +Module: Crypto.Spake2.Groups +Description: Implementation of various mathematical groups + +Each of these implements the 'Crypto.Spake2.Group.Group' typeclass. +-} +module Crypto.Spake2.Groups + ( Ed25519.Ed25519(..) + , IntegerGroup.IntegerGroup(..) + , IntegerGroup.makeIntegerGroup + , IntegerGroup.i1024 + -- * For testing only + , IntegerAddition.IntegerAddition(..) + ) where + +import qualified Crypto.Spake2.Groups.Ed25519 as Ed25519 +import qualified Crypto.Spake2.Groups.IntegerAddition as IntegerAddition +import qualified Crypto.Spake2.Groups.IntegerGroup as IntegerGroup diff --git a/src/Crypto/Spake2/Groups/Ed25519.hs b/src/Crypto/Spake2/Groups/Ed25519.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Groups/Ed25519.hs @@ -0,0 +1,433 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-| +Module: Crypto.Spake2.Groups.Ed25519 +Description: Ed25519 group for SPAKE2 + +Derived from @ed25519_basic.py@ in [python-spake2](https://github.com/warner/python-spake2), +in turn derived from the slow, reference, Python implementation at + +-} +module Crypto.Spake2.Groups.Ed25519 + ( Ed25519(..) + -- * Exported for testing + , l + , generator + ) where + +import Protolude hiding (clamp, group, zero) + +import Crypto.Error (CryptoFailable(..), CryptoError(..)) +import Crypto.Number.Generate (generateMax) +import Crypto.Number.ModArithmetic (expSafe, inverseCoprimes) +import Crypto.Number.Serialize (i2osp, os2ip) +import Data.ByteArray (ByteArray, ByteArrayAccess) +import qualified Data.ByteArray as ByteArray +import qualified Data.List as List + +import Crypto.Spake2.Group (Group(..), KeyPair(..), scalarSizeBytes) +import Crypto.Spake2.Util (bytesToNumber, expandArbitraryElementSeed) + +{- +Note [Ed25519 vs curve25519] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As best as jml can tell, + +* X25519 is Elliptic Curve Diffie-Hellman (ECDH) over Curve25519 +* Ed25519 is Edwards-curve Digital Signature Algorithm (EdDSA) over Curve25519 + +(quoted from a [StackOverflow answer](https://crypto.stackexchange.com/questions/27866/why-curve25519-for-encryption-but-ed25519-for-signatures)) + +This means the underlying curve is the same, +and Ed25519 is the use of that curve in signing, +and X25519 is the curve used in key exchange. + +Complicated by the fact that Curve25519 /used/ to be the name of ECDH over Curve25519. + +Since our primary goal is Python interoperability, +we are going to implement an analogue of the Python code here, +and call it Ed25519. + +Once that is done, we can explore using Cryptonite's Curve25519 logic, +ideally demonstrating its equivalence with some automated tests. + + + +-} + +data Ed25519 = Ed25519 deriving (Eq, Show) + +instance Group Ed25519 where + type Scalar Ed25519 = Integer + type Element Ed25519 = ExtendedPoint 'Member + + elementAdd _ x y = addExtendedPoints x y + elementNegate group = scalarMultiply group (l - 1) + groupIdentity _ = assertInGroup extendedZero + scalarMultiply _ n x = safeScalarMultiply n x + + integerToScalar _ x = x + scalarToInteger _ x = x + + encodeElement _ x = encodeAffinePoint (extendedToAffine' x) + decodeElement _ bytes = toCryptoFailable $ do + affine <- decodeAffinePoint bytes + let extended = affineToExtended affine + ensureInGroup extended + + generateElement group = do + scalar <- generateMax l + let element = scalarMultiply group scalar generator + pure (KeyPair element scalar) + + elementSizeBits _ = 255 + scalarSizeBits _ = 255 + + arbitraryElement group bytes = + let seed = expandArbitraryElementSeed bytes (scalarSizeBytes group + 16) :: ByteString + y = bytesToNumber seed `mod` q + in + List.head [ element | Right element <- map makeGroupMember [y..] ] + +-- | Errors that can occur within the group. +data Error + = NotOnCurve Integer Integer + | NotInGroup (ExtendedPoint 'Unknown) + | LowOrderPoint (ExtendedPoint 'Unknown) + deriving (Eq, Show) + +-- | Translate internal errors into CryptoFailable. +toCryptoFailable :: Either Error a -> CryptoFailable a +toCryptoFailable (Right r) = pure r +toCryptoFailable (Left _) = CryptoFailed CryptoError_PointCoordinatesInvalid + +-- | Guarantee an element is in the Ed25519 subgroup. +ensureInGroup :: ExtendedPoint 'Unknown -> Either Error (ExtendedPoint 'Member) +ensureInGroup element@ExtendedPoint{x, y, z, t} = + if isExtendedZero (safeScalarMultiply l element) + then pure ExtendedPoint { x = x, y = y, z = z, t = t} + else throwError $ NotInGroup element + +-- | Assert that an element is the Ed25519 subgroup. +-- +-- Panics if it is not. +assertInGroup :: HasCallStack => ExtendedPoint 'Unknown -> ExtendedPoint 'Member +assertInGroup element = + -- XXX: Should we force evaluation of this? We mostly use it only for + -- constants. + case ensureInGroup element of + Left err -> panic $ "Element not in group (" <> show err <> "): " <> show element + Right x -> x + +-- TODO: Document this. +-- Guess: the size of the subgroup? the group? +q :: Integer +q = 2 ^ 255 - 19 -- XXX: force eval? + +-- | The order of the group represented by 'Ed25519'. +-- +-- Note that this is a subgroup of the underlying elliptic curve. +l :: Integer +l = 2 ^ 252 + 27742317777372353535851937790883648493 + +-- TODO document this +dConst :: Integer +dConst = -121665 * inv 121666 -- XXX: force eval? + +-- TODO document this +i :: Integer +i = expSafe 2 ((q-1) `div` 4) q -- XXX: force eval + +-- | The generator for the (sub)group represented by 'Ed25519'. +generator :: Element Ed25519 +generator = assertInGroup $ affineToExtended b + where + b = case makeAffinePoint (x `mod` q) (y `mod` q) of + Left err -> panic $ "Generator is not affine point: " <> show err + Right r -> r + x = xRecover y + y = 4 * inv 5 + +-- | Calculate the inverse of @x@ modulo 'q'. +-- +-- Assumes that @x@ is coprime with 'q' and non-zero. +-- Will raise an exception if either of these assumptions is false. +-- +-- prop> \x -> (x * inv x) `mod` q == 1 +inv :: Integer -> Integer +inv x = inverseCoprimes x q + +xRecover :: Integer -> Integer +xRecover y = + let x'' = (y * y - 1) * inv(dConst * y * y + 1) + x' = expSafe x'' ((q + 3) `div` 8) q + x = if (x' * x' - x'') `mod` q /= 0 + then (x' * i) `mod` q + else x' + in + if even x then x else q - x + + +-- | Whether or not an extended point is a member of Ed25519. +data GroupMembership = Unknown | Member + +-- | A point that might be a member of Ed25519. +-- Note: [Extended coordinates] +data ExtendedPoint (groupMembership :: GroupMembership) + = ExtendedPoint + { x :: !Integer + , y :: !Integer + , z :: !Integer + , t :: !Integer + } deriving (Show) + +-- XXX: jml unsure about overriding equality like this. +-- Note: [Extended coordinates] +instance Eq (ExtendedPoint a) where + point1 == point2 = extendedToAffine' point1 == extendedToAffine' point2 + +-- | Zero in the extended coordinate space. +-- +-- > affineZero = AffinePoint{x = 0, y = 1} +-- > extendedZero == affineToExtended affineZero +-- +-- Note: [Extended coordinates] +extendedZero :: ExtendedPoint a +extendedZero = ExtendedPoint {x = 0, y = 1, z = 1, t = 0} + +-- | Check if a point is equivalent to zero. +-- +-- jml is unsure, but this probably exists because it might be faster than +-- mapping to affine space and checking for equality. +-- +-- Note: [Extended coordinates] +isExtendedZero :: ExtendedPoint irrelevant -> Bool +isExtendedZero ExtendedPoint{x, y, z} = x == 0 && y' == z' && y' /= 0 + where + y' = y `mod` q + z' = z `mod` q + +-- | Add two extended points. +-- +-- The points don't have to be in the Ed25519 subgroup, and we can't say +-- anything about whether the result will be. +-- +-- add-2008-hwcd-3 +addExtendedPoints :: ExtendedPoint a -> ExtendedPoint a -> ExtendedPoint a +addExtendedPoints ExtendedPoint{x = x1, y = y1, z = z1, t = t1} ExtendedPoint{x = x2, y = y2, z = z2, t = t2} = + ExtendedPoint{x = x3, y = y3, z = z3, t = t3} + where + -- X3 = (E*F) % Q + x3 = (e * f) `mod` q + -- Y3 = (G*H) % Q + y3 = (g * h) `mod` q + -- Z3 = (F*G) % Q + z3 = (f * g) `mod` q + -- T3 = (E*H) % Q + t3 = (e * h) `mod` q + + -- E = (B-A) % Q + e = (b - a) `mod` q + -- F = (D-C) % Q + f = (d' - c) `mod` q + -- G = (D+C) % Q + g = (d' + c) `mod` q + -- H = (B+A) % Q + h = (b + a) `mod` q + + -- A = ((Y1-X1)*(Y2-X2)) % Q + a = ((y1 - x1) * (y2 - x2)) `mod` q + -- B = ((Y1+X1)*(Y2+X2)) % Q + b = ((y1 + x1) * (y2 + x2)) `mod` q + -- C = T1*(2*d)*T2 % Q + c = (t1 * (2 * dConst) * t2) `mod` q + -- D = Z1*2*Z2 % Q + d' = (z1 * 2 * z2) `mod` q + +-- | Double an extended point. +-- +-- dbl-2008-hwcd +doubleExtendedPoint :: ExtendedPoint preserving -> ExtendedPoint preserving +doubleExtendedPoint ExtendedPoint{x = x1, y = y1, z = z1} = + ExtendedPoint{x= x3, y = y3, z = z3, t = t3} + where + -- X3 = (E*F) % Q + x3 = (e * f) `mod` q + -- Y3 = (G*H) % Q + y3 = (g * h) `mod` q + -- Z3 = (F*G) % Q + z3 = (f * g) `mod` q + -- T3 = (E*H) % Q + t3 = (e * h) `mod` q + + -- E = (J*J-A-B) % Q + e = (j * j - a -b) `mod` q + -- F = (G-C) % Q + f = (g - c) `mod` q + -- G = (D+B) % Q + g = (d' + b) `mod` q + -- H = (D-B) % Q + h = (d' - b) `mod` q + + -- A = (X1*X1) + a = x1 * x1 + -- B = (Y1*Y1) + b = y1 * y1 + -- C = (2*Z1*Z1) + c = 2 * z1 * z1 + -- D = (-A) % Q + d' = (-a) `mod` q + -- J = (X1+Y1) % Q + j = (x1 + y1) `mod` q + +-- | Multiply a point (might be in the group, might not) by a scalar. +safeScalarMultiply :: Integer -> ExtendedPoint a -> ExtendedPoint a +safeScalarMultiply n = scalarMultiplyExtendedPoint addExtendedPoints n + +-- | Scalar multiplication parametrised by addition. +scalarMultiplyExtendedPoint :: (ExtendedPoint a -> ExtendedPoint a -> ExtendedPoint a) -> Integer -> ExtendedPoint a -> ExtendedPoint a +scalarMultiplyExtendedPoint _ 0 _ = extendedZero +scalarMultiplyExtendedPoint add n x + | n >= l = scalarMultiplyExtendedPoint add (n `mod` l) x + | even n = doubleExtendedPoint (scalarMultiplyExtendedPoint add (n `div` 2) x) + | n == 1 = x + | n <= 0 = panic $ "Unexpected negative multiplier: " <> show n + | otherwise = add x (scalarMultiplyExtendedPoint add (n - 1) x) + + +-- | Attempt to create a member of Ed25519 from an affine @y@ coordinate. +makeGroupMember :: Integer -> Either Error (Element Ed25519) +makeGroupMember y = do + -- XXX: Similar to decodeElement. Can we share code? + point <- affineToExtended <$> makeAffinePoint (xRecover y) y + let point8 = safeScalarMultiply 8 point + if isExtendedZero point8 + then throwError $ LowOrderPoint point + else ensureInGroup point8 + +{- +Note: [Arbitrary point generation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This is cribbed from warner's notes in python-spake2: + + +* only about 50% of Y coordinates map to valid curve points +* even if the point is on our curve, it may not be in our particular (order=l) subgroup + The curve has order 8*L, so an arbitrary point could have order 1,2,4,8,1*L,2*L,4*L,8*L + (everything which divides the group order) +* 50% of random points will have order 8*L, + 25% will have order 4*L, + 13% order 2*L, + 13% will have our desired order 1*L + (and a vanishingly small fraction will have 1/2/4/8). +* If we multiply any of the 8*L points by 2, we're sure to get an 4*L point + (and multiplying a 4*L point by 2 gives us a 2*L point, and so on). +* Multiplying a 1*L point by 2 gives us a different 1*L point. + So multiplying by 8 gets us from almost any point into a uniform point on the correct 1*L subgroup. +* We might still get really unlucky and pick one of the 8 low-order points. + Multiplying by 8 will get us to the identity (Zero), which we check for explicitly. +* Double check that *this* point (8 * P) is in the right subgroup. + +That final check is a Python assertion, +which would crash the program if incorrect. +For programming convenience, I just skip these values. + +jml doesn't know what is meant by the 'order' of a point. + +-} + +-- TODO: Document this +data AffinePoint + = AffinePoint + { x :: !Integer + , y :: !Integer + } deriving (Eq, Show) + +-- | Construct an affine point that is on Curve25519. +makeAffinePoint :: Integer -> Integer -> Either Error AffinePoint +makeAffinePoint x y + | isOnCurve x y = pure AffinePoint { x = x, y = y } + | otherwise = throwError $ NotOnCurve x y + where + isOnCurve x' y' = ((-x') * x' + y' * y' - 1 - dConst * x' * x' * y' * y') `mod` q == 0 + +-- | Encode an 'AffinePoint' into bytes. +-- +-- MSB of the output is whether or not @x@ is even (i.e. @x .&. 1@), +-- teh rest of the output is little-endian @y@. +encodeAffinePoint :: (ByteArray bytes, ByteArrayAccess bytes) => AffinePoint -> bytes +encodeAffinePoint AffinePoint{x, y} + | even x = numberToLitteEndianBytes y + | otherwise = numberToLitteEndianBytes (y + shift 1 255) + +decodeAffinePoint :: (ByteArray bytes, ByteArrayAccess bytes) => bytes -> Either Error AffinePoint +decodeAffinePoint bytes = + let unclamped = littleEndianBytesToNumber bytes + clamp = shift 1 255 - 1 + y = unclamped .&. clamp + x = xRecover y + x' = if x .&. 1 == unclamped .&. shift 1 255 then x else q - x + in makeAffinePoint x' y + + +numberToLitteEndianBytes :: ByteArray bytes => Integer -> bytes +numberToLitteEndianBytes n = ByteArray.pack (reverse (ByteArray.unpack (i2osp n :: ByteString))) + +littleEndianBytesToNumber :: (ByteArray bytes, ByteArrayAccess bytes) => bytes -> Integer +littleEndianBytesToNumber bytes = os2ip (ByteArray.pack (reverse (ByteArray.unpack bytes)) :: ByteString) + +{- +Note: [Extended coordinates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +jml only partly understands these. Here's that understanding. + +The underlying elliptic curve is two-dimensional. +These are the AffinePoints. +We project that curve into a 4-dimensional space, +i.e. to the ExtendedPoints. + +Doing so makes some of the arithmetic faster. +But ultimately, the values we are interested in are the affine points. + +Thus, even if two ExtendedPoints have differing values internally, +they might be equivalent with respect to the Ed25519 group. + +That is, +the affine points form a group +the extended points form a group +you can get a subgroup of the extended points group isomorphic to the affine points group +by using "maps to the same affine point" as an equivalence relation. + +The Python version goes to some lengths to avoid doing calculations with zero. +In an earlier revision, I preserved that behaviour, +however, I have since removed it, +as we have no performance data, +and it adds extra complexity. + +This URL might help: +http://www.hyperelliptic.org/EFD/g1p/auto-twisted-extended-1.html +-} + +affineToExtended :: AffinePoint -> ExtendedPoint 'Unknown +affineToExtended AffinePoint{x, y} = + ExtendedPoint + { x = x `mod` q + , y = y `mod` q + , z = 1 + , t = (x * y) `mod` q + } + +extendedToAffine' :: ExtendedPoint a -> AffinePoint +extendedToAffine' ExtendedPoint{x, y, z} = + case makeAffinePoint x' y' of + Left err -> panic $ "Could not make affine point: " <> show err + Right r -> r + where + x' = (x * inv z) `mod` q + y' = (y * inv z) `mod` q diff --git a/src/Crypto/Spake2/Groups/IntegerAddition.hs b/src/Crypto/Spake2/Groups/IntegerAddition.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Groups/IntegerAddition.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE TypeFamilies #-} +{-| +Module: Crypto.Spake2.Groups +Description: Additive group of integers modulo \(n\) + +Do __NOT__ use this for anything cryptographic. +-} +module Crypto.Spake2.Groups.IntegerAddition + ( IntegerAddition(..) + ) where + +import Protolude hiding (group, length) + +import Crypto.Error (CryptoFailable(..)) +import Crypto.Number.Basic (numBits) +import Crypto.Number.ModArithmetic (expSafe) +import Crypto.Random.Types (MonadRandom(..)) + +import Crypto.Spake2.Group + ( Group(..) + , KeyPair(..) + , decodeScalar + , elementSizeBytes + , scalarSizeBytes + ) +import Crypto.Spake2.Util + ( expandArbitraryElementSeed + , bytesToNumber + , unsafeNumberToBytes + ) + +-- | Simple integer addition group. +-- +-- Do __NOT__ use this for anything cryptographic. +newtype IntegerAddition = IntegerAddition { modulus :: Integer } deriving (Eq, Ord, Show) + +instance Group IntegerAddition where + type Element IntegerAddition = Integer + type Scalar IntegerAddition = Integer + + elementAdd group x y = (x + y) `mod` modulus group + elementNegate group x = negate x `mod` modulus group + elementSubtract group x y = (x - y) `mod` modulus group + groupIdentity _ = 0 + scalarMultiply group n x = (n * x) `mod` modulus group + integerToScalar _ x = x + scalarToInteger _ x = x + encodeElement group x = unsafeNumberToBytes (elementSizeBytes group) (x `mod` modulus group) + decodeElement _ bytes = CryptoPassed (bytesToNumber bytes) + generateElement group = do + scalarBytes <- getRandomBytes (scalarSizeBytes group) + let scalar = decodeScalar group (scalarBytes :: ByteString) + let element = scalarMultiply group scalar (groupIdentity group) + pure (KeyPair element scalar) + scalarSizeBits group = numBits (modulus group) -- XXX: Incorrect value. Not sure what it should be. + elementSizeBits group = numBits (modulus group) -- XXX: should be size of subgroup + arbitraryElement group seed = + let processedSeed = expandArbitraryElementSeed seed (elementSizeBytes group) :: ByteString + r = (modulus group - 1) `div` modulus group -- XXX: should be size of subgroup + h = bytesToNumber processedSeed `mod` modulus group + in expSafe h r (modulus group) + + diff --git a/src/Crypto/Spake2/Groups/IntegerGroup.hs b/src/Crypto/Spake2/Groups/IntegerGroup.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Groups/IntegerGroup.hs @@ -0,0 +1,95 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-| +Module: Crypto.Spake2.Groups.IntegerGroup +Description: Multiplicative group of integers modulo \(n\) +-} +module Crypto.Spake2.Groups.IntegerGroup + ( IntegerGroup(..) + , makeIntegerGroup + , i1024 + ) where + +import Protolude hiding (group, length) + +import Crypto.Error (CryptoFailable(..), CryptoError(..)) +import Crypto.Number.Basic (numBits) +import Crypto.Number.Generate (generateMax) +import Crypto.Number.ModArithmetic (expSafe) + +import Crypto.Spake2.Group + ( Group(..) + , KeyPair(..) + , elementSizeBytes + ) +import Crypto.Spake2.Util + ( expandArbitraryElementSeed + , bytesToNumber + , unsafeNumberToBytes + ) + +-- | A finite group of integers with respect to multiplication modulo the group order. +-- +-- Construct with 'makeIntegerGroup'. +data IntegerGroup + = IntegerGroup + { order :: !Integer + , subgroupOrder :: !Integer + , generator :: !Integer + } deriving (Eq, Show) + +-- | Construct an 'IntegerGroup'. +-- +-- Will fail if generator is '1', +-- since having the identity for a generator means the subgroup is the entire group. +-- +-- TODO: Find other things to check for validity. +makeIntegerGroup :: Integer -> Integer -> Integer -> Maybe IntegerGroup +makeIntegerGroup _ _ 1 = Nothing +makeIntegerGroup order subgroupOrder generator = Just (IntegerGroup order subgroupOrder generator) + + +instance Group IntegerGroup where + type Element IntegerGroup = Integer + type Scalar IntegerGroup = Integer + + elementAdd group x y = (x * y) `mod` order group + -- At a guess, negation is scalar multiplication where the scalar is -1 + elementNegate group x = expSafe x (subgroupOrder group - 1) (order group) + groupIdentity _ = 1 + scalarMultiply group n x = expSafe x (n `mod` subgroupOrder group) (order group) + integerToScalar group x = x `mod` subgroupOrder group -- XXX: Should we instead fail? + scalarToInteger _ n = n + encodeElement group = unsafeNumberToBytes (elementSizeBytes group) + decodeElement group bytes = + case bytesToNumber bytes of + x + | x <= 0 || x >= order group -> CryptoFailed CryptoError_PointSizeInvalid + | expSafe x (subgroupOrder group) (order group) /= groupIdentity group -> CryptoFailed CryptoError_PointCoordinatesInvalid + | otherwise -> CryptoPassed x + generateElement group = do + scalar <- generateMax (subgroupOrder group) + let element = scalarMultiply group scalar (generator group) + pure (KeyPair element scalar) + scalarSizeBits group = numBits (subgroupOrder group) + elementSizeBits group = numBits (order group) + arbitraryElement group seed = + let processedSeed = expandArbitraryElementSeed seed (elementSizeBytes group) :: ByteString + p = order group + q = subgroupOrder group + r = (p - 1) `div` q + h = bytesToNumber processedSeed `mod` p + in expSafe h r p + +-- | 1024 bit integer group. +-- +-- Originally from http://haofeng66.googlepages.com/JPAKEDemo.java, +-- via [python-spake2](https://github.com/warner/python-spake2). +i1024 :: IntegerGroup +i1024 = + IntegerGroup + { order = 0xE0A67598CD1B763BC98C8ABB333E5DDA0CD3AA0E5E1FB5BA8A7B4EABC10BA338FAE06DD4B90FDA70D7CF0CB0C638BE3341BEC0AF8A7330A3307DED2299A0EE606DF035177A239C34A912C202AA5F83B9C4A7CF0235B5316BFC6EFB9A248411258B30B839AF172440F32563056CB67A861158DDD90E6A894C72A5BBEF9E286C6B + , subgroupOrder = 0xE950511EAB424B9A19A2AEB4E159B7844C589C4F + , generator = 0xD29D5121B0423C2769AB21843E5A3240FF19CACC792264E3BB6BE4F78EDD1B15C4DFF7F1D905431F0AB16790E1F773B5CE01C804E509066A9919F5195F4ABC58189FD9FF987389CB5BEDF21B4DAB4F8B76A055FFE2770988FE2EC2DE11AD92219F0B351869AC24DA3D7BA87011A701CE8EE7BFE49486ED4527B7186CA4610A75 + } diff --git a/src/Crypto/Spake2/Math.hs b/src/Crypto/Spake2/Math.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Math.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +{-| +Module: Crypto.Spake2.Math +Description: The mathematical implementation of SPAKE2. + +This module ignores everything about networks, bytes, encoding, hash functions, and so forth. +All it does is provide the mathematical building blocks for SPAKE2, +as per [Simple Password-Based Encrypted Key Exchange Protocols](http://www.di.ens.fr/~pointche/Documents/Papers/2005_rsa.pdf) +by Michel Abdalla and David Pointcheval. + +== How it works + +=== Preliminaries + +Let's say we have two users, user A and user B. +They have already agreed on the following public information: + + * cyclic group, \(G\) of prime order, \(p\) + * generating element \(g \in G\), such that \(g \neq 1\) + * hash algorithm to use, \(H\) + +If the connection is asymmetric +(e.g. if user A is a client and user B is a server), +then they will also have: + + * two arbitrary elements in \(M, N \in G\), where \(M\) is associated with + user A and \(N\) with user B. + +If the connection is symmetric +(e.g. if user A and B are arbitrary peers), +then they will instead have: + + * a single arbitrary element \(S \in G\) + +The discrete log of these arbitrary elements must be difficult to guess. + +And, they also have a secret password, +which in practice will be an arbitrary byte string, +but for the purposes of this module is an arbitrary /scalar/ in the group +that is a shared secret between both parties +(see "Crypto.Spake2.Groups" for more information on scalars). + +=== The protocol + +/This is derived from the paper linked above./ + +One side, A, initiates the exchange. +They draw a random scalar, \(x\), and matching element, \(X\), from the group. +They then "blind" \(X\) by adding it to \(M\) multiplied by the password in scalar form. +Call this \(X^{\star}\). + +\[X^{\star} \leftarrow X \cdot M^{pw}\] + +to the other side, side B. + +Side B does the same thing, +except they use \(N\) instead of \(M\) to blind the result, +and they call it \(Y\) instead of \(X\). + +\[Y^{\star} \leftarrow Y \cdot N^{pw}\] + +After side A receives \(Y^{\star}\), +it calculates \(K_A\), +which is the last missing input in calculating the session key. + +\[K_A \leftarrow (Y^{\star}/N^{pw})^x\] + +That is, \(K_A\) is \(Y^{\star}\) subtracted from \(N\) scalar multiplied by \(pw\), +all of which is scalar multiplied by \(x\). + +Side B likewise calculates: + +\[K_B \leftarrow (X^{\star}/M^{pw})^y\] + +If both parties were honest and knew the password, +the keys will be the same on both sides. +That is: + +\[K_A = K_B\] + +=== How to use the keys + +The keys \(K_A\) and \(K_B\) are not enough to securely encrypt a session. +They must be used as input to create a session key. + +Constructing a session key is beyond the scope of this module. +See 'createSessionKey' for more information. + +-} + +module Crypto.Spake2.Math + ( Spake2(..) -- XXX: Not sure want to export innards but it disables "unused" warning + , Params(..) -- XXX: ditto + , startSpake2 + , Spake2Exchange + , computeOutboundMessage + , generateKeyMaterial + ) where + +import Protolude hiding (group) + +import Crypto.Random.Types (MonadRandom(..)) + +import Crypto.Spake2.Group (Group(..), KeyPair(..)) + +-- | The parameters of the SPAKE2 protocol. The other side needs to be using +-- the same values, but with swapped values for 'ourBlind' and 'theirBlind'. +data Params group + = Params + { group :: group -- ^ The cyclic group used for encrypting keys + , ourBlind :: Element group -- ^ The "blind" we use when sending out values. Side A refers to this as \(M\) in the protocol description. + , theirBlind :: Element group -- ^ The "blind" the other side uses when sending values. Side A refers to this as \(N\) in the protocol description. + } + +-- | An instance of the SPAKE2 protocol. This represents one side of the protocol. +data Spake2 group + = Spake2 + { params :: Params group + , password :: Scalar group + } + +-- | A SPAKE2 exchange that has been initiated. +data Spake2Exchange group + = Started + { spake2 :: Spake2 group -- ^ Description of the specific instance of the + -- SPAKE2 protocol we are using. Parameters, + -- password, and group must be the same for this to + -- work. + , xy :: KeyPair group -- ^ Arbitrary element and scalar chosen by this side of the exchange. + -- It is kept secret, and is only used to negotiate an exchange. + -- A "blinded" form is sent to the other side of the protocol. + } + +-- | Initiate the SPAKE2 exchange. Generates a secret (@xy@) that will be held +-- by this side, and transmitted to the other side in "blinded" form. +startSpake2 :: (Group group, MonadRandom randomly) => Spake2 group -> randomly (Spake2Exchange group) +startSpake2 spake2' = Started spake2' <$> generateElement (group . params $ spake2') + +-- | Determine the element (either \(X^{\star}\) or \(Y^{\star}\)) to send to the other side. +computeOutboundMessage :: Group group => Spake2Exchange group -> Element group +computeOutboundMessage Started{spake2 = Spake2{params = Params{group, ourBlind}, password}, xy} = + elementAdd group (keyPairPublic xy) (scalarMultiply group password ourBlind) + +-- | Generate key material, \(K\), given a message from the other side (either +-- \(Y^{\star}\) or \(X^{\star}\)). +-- +-- This key material is the last piece of input required to make the session +-- key, \(SK\), which should be generated as: +-- +-- \[SK \leftarrow H(A, B, X^{\star}, Y^{\star}, K, pw)\] +-- +-- Where: +-- +-- * \(H\) is a hash function +-- * \(A\) identifies the initiating side +-- * \(B\) identifies the receiving side +-- * \(X^{star}\) is the outbound message from the initiating side +-- * \(Y^{star}\) is the outbound message from the receiving side +-- * \(K\) is the result of this function +-- * \(pw\) is the password (this is what makes it SPAKE2, not SPAKE1) +generateKeyMaterial + :: Group group + => Spake2Exchange group -- ^ An initiated SPAKE2 exchange + -> Element group -- ^ The outbound message from the other side (i.e. inbound to us) + -> Element group -- ^ The final piece of key material to generate the session key. +generateKeyMaterial Started{spake2 = Spake2{params = Params{group, theirBlind}, password}, xy} inbound = + scalarMultiply group (keyPairPrivate xy) (elementSubtract group inbound (scalarMultiply group password theirBlind)) diff --git a/src/Crypto/Spake2/Util.hs b/src/Crypto/Spake2/Util.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Spake2/Util.hs @@ -0,0 +1,70 @@ +{-| +Module: Crypto.Spake2.Util +Description: Miscellany. Mostly to do with serialization. +-} +module Crypto.Spake2.Util + ( expandData + , expandArbitraryElementSeed + , bytesToNumber + , numberToBytes + , unsafeNumberToBytes + ) where + +import Protolude + +import Crypto.Hash.Algorithms (SHA256) +import Crypto.Number.Serialize (os2ip, i2ospOf, i2ospOf_) +import qualified Crypto.KDF.HKDF as HKDF +import Data.ByteArray (ByteArray, ByteArrayAccess(..)) + +-- TODO: memory package (a dependency of cryptonite) has +-- Data.ByteArray.Encoding, which does base16 encoding. Perhaps we should use +-- that rather than third-party base16-bytestring library. + +-- | Take an arbitrary sequence of bytes and expand it to be the given number +-- of bytes. Do this by extracting a pseudo-random key and expanding it using +-- HKDF. +expandData :: (ByteArrayAccess input, ByteArray output) => ByteString -> input -> Int -> output +expandData info input size = + HKDF.expand prk info size + where + prk :: HKDF.PRK SHA256 + prk = HKDF.extract salt input + + -- XXX: I'm no crypto expert, but hard-coding an empty string as a salt + -- seems kind of weird. + salt :: ByteString + salt = "" + +-- | Given a seed value for an arbitrary element (see 'arbitraryElement'), +-- expand it to be of the given length. +expandArbitraryElementSeed :: (ByteArrayAccess ikm, ByteArray out) => ikm -> Int -> out +expandArbitraryElementSeed = + -- NOTE: This must be exactly this string in order to interoperate with python-spake2 + expandData "SPAKE2 arbitrary element" + + +-- | Serialize a number according to the SPAKE2 protocol. +-- +-- Just kidding, there isn't a SPAKE2 protocol. +-- This just matches the Python implementation. +-- +-- Inverse of 'bytesToNumber'. +numberToBytes :: ByteArray bytes => Int -> Integer -> Maybe bytes +numberToBytes = i2ospOf + +-- | Serialize a number according to the SPAKE2 protocol. +-- +-- Panics if the number is too big to fit into the given number of bytes. +unsafeNumberToBytes :: ByteArray bytes => Int -> Integer -> bytes +unsafeNumberToBytes = i2ospOf_ + + +-- | Deserialize a number according to the SPAKE2 protocol. +-- +-- Just kidding, there isn't a SPAKE2 protocol. +-- This just matches the Python implementation. +-- +-- Inverse of 'numberToBytes'. +bytesToNumber :: ByteArrayAccess bytes => bytes -> Integer +bytesToNumber = os2ip diff --git a/tests/Groups.hs b/tests/Groups.hs new file mode 100644 --- /dev/null +++ b/tests/Groups.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Groups (tests) where + +import Protolude hiding (group) + +import Crypto.Error (CryptoFailable(..)) +import GHC.Base (String) +import Test.QuickCheck (Gen, (===), arbitrary, forAll, property) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (Spec, testSpec, describe, it, shouldBe) + +import Crypto.Spake2.Group (Group(..)) +import Crypto.Spake2.Groups + ( IntegerAddition(..) + , IntegerGroup(..) + , Ed25519(..) + , i1024) +import qualified Crypto.Spake2.Groups.Ed25519 as Ed25519 +import qualified Crypto.Spake2.Groups.IntegerGroup as IntegerGroup + +tests :: IO TestTree +tests = testSpec "Groups" $ do + groupProperties "integer addition modulo 7" (IntegerAddition 7) 1 (makeScalar 7) + groupProperties "integer group" i1024 (IntegerGroup.generator i1024) (makeScalar (subgroupOrder i1024)) + groupProperties "Ed25519" Ed25519 Ed25519.generator (makeScalar Ed25519.l) + + +makeScalar :: Integer -> Gen Integer +makeScalar k = do + i <- arbitrary + pure $ i `mod` k + +makeElement :: Group group => group -> Gen (Scalar group) -> Element group -> Gen (Element group) +makeElement group scalars base = do + scalar <- scalars + pure (scalarMultiply group scalar base) + +groupProperties + :: (Group group, Eq (Element group), Eq (Scalar group), Show (Element group), Show (Scalar group)) + => String + -> group + -> Element group + -> Gen (Scalar group) + -> Spec +groupProperties name group base scalars = describe name $ do + it "addition is associative" $ property $ + forAll triples $ \(x, y, z) -> elementAdd group (elementAdd group x y) z === elementAdd group x (elementAdd group y z) + + it "addition with inverse yields identity" $ property $ + forAll elements $ \x -> elementAdd group x (elementNegate group x) === groupIdentity group + + it "double negative is no-op" $ property $ + forAll elements $ \x -> elementNegate group (elementNegate group x) === x + + it "identity is its own inverse" $ + elementNegate group (groupIdentity group) `shouldBe` groupIdentity group + + it "subtraction is negated addition" $ property $ + forAll pairs $ \(x, y) -> elementSubtract group x y === elementAdd group x (elementNegate group y) + + it "right-hand addition with identity yields original" $ property $ + forAll elements $ \x -> elementAdd group x (groupIdentity group) === x + + it "left-hand addition with identity yields original" $ property $ + forAll elements $ \x -> elementAdd group (groupIdentity group) x === x + + it "element codec roundtrips" $ property $ + forAll elements $ \x -> let bytes = encodeElement group x :: ByteString + in decodeElement group bytes == CryptoPassed x + + it "scalar to integer roundtrips" $ property $ + forAll scalars $ \n -> integerToScalar group (scalarToInteger group n) === n + + it "integer to scalar conversion" $ property $ + -- Doesn't roundtrip per se, because negative integers (for example) get + -- turned into scalars within the subgroup range, losing the original + -- information. + \i -> integerToScalar group (scalarToInteger group (integerToScalar group i)) === integerToScalar group i + + it "scalar multiply by 0 is identity" $ property $ + forAll elements $ \x -> scalarMultiply group (integerToScalar group 0) x === groupIdentity group + + it "scalar multiply by 1 is original" $ property $ + forAll elements $ \x -> scalarMultiply group (integerToScalar group 1) x === x + + it "scalar multiply by 2 is equivalent to addition" $ property $ + forAll elements $ \x -> scalarMultiply group (integerToScalar group 2) x === elementAdd group x x + + where + elements = makeElement group scalars base + + pairs = do + x <- elements + y <- elements + pure (x, y) + + triples = do + x <- elements + y <- elements + z <- elements + pure (x, y, z) diff --git a/tests/Spake2.hs b/tests/Spake2.hs new file mode 100644 --- /dev/null +++ b/tests/Spake2.hs @@ -0,0 +1,13 @@ +module Spake2 (tests) where + +import Protolude +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) + +import qualified Crypto.Spake2 as Spake2 + +tests :: IO TestTree +tests = testSpec "Spake2" $ do + describe "something" $ + it "should do things" $ + Spake2.something (2 :: Int) `shouldBe` 2 diff --git a/tests/Tasty.hs b/tests/Tasty.hs new file mode 100644 --- /dev/null +++ b/tests/Tasty.hs @@ -0,0 +1,18 @@ +module Main + ( main + ) where + +import Protolude + +import Test.Tasty (defaultMain, testGroup) + +import qualified Spake2 +import qualified Groups + +main :: IO () +main = sequence tests >>= defaultMain . testGroup "Spake2" + where + tests = + [ Spake2.tests + , Groups.tests + ]